加快删除工作表上隐藏的行的代码

下面我有一些我写的代码。 这是非常有效的，没有任何错误。 然而，这是非常非常缓慢的。 子接受一张给定的工作表，并检查隐藏的行。 如果所有行都隐藏，则删除该表单。 如果不是，则删除所有隐藏的行。

这是运行在另一个子，所有的东西，如screenupdating和事件都被禁用。

我研究了加速代码的常用方法（这里： 如何提高VBAmacros代码的速度？ ，这里： http ： //www.databison.com/how-to-speed-up-calculation-and-improve-performance -of-excel-and-vba / ，在这里： http ： //www.ozgrid.com/VBA/SpeedingUpVBACode.htm ），但还没有能够申请太多。

请看一下，让我知道你认为我可以做些什么来加快速度。 如果还有其他的编码错误，请让我知道。

谢谢！

Sub RhidRow(ByVal count4 As Double) 'count 4 is the total number of possible rows Dim count6, count1, count9 As Double 'counters to be used count6 = 2 'begin on row two count1 = 0 'check for visible rows counter With ActiveSheet While count6 < count4 DoEvents Application.StatusBar = "Checking row " & count6 & " of " & count4 & "." If Range("A" & CStr(count6)).EntireRow.Hidden = False Then count1 = count1 + 1 'if there was a visible row, then add one End If count6 = count6 + 1 'move to next row to check Wend Range("N7") = count6 'so I can hand check results If count1 = 0 Then 'if there were no visible rows, then set Z1 to 1 and exit Range("Z1").Value = 1 'to error check in another sub. if Z1=1, then delete Exit Sub End If count6 = 2 'start on row 2 count9 = 1 'count 9 While count9 < count4 'while the row is less than the count of the total rows DoEvents Application.StatusBar = count6 & " or " & count9 & " of " & count4 If Range("A" & CStr(count6)).EntireRow.Hidden = True Then Range("A" & CStr(count6)).EntireRow.Delete 'if row is hidden, delete Else count6 = count6 + 1 'if it is not hidden, move to the next row End If count9 = count9 + 1 'show what row it is on in the status bar Wend End With End Sub 

我已经在评论中提出了改变，并摆脱了ActiveSheet。 速度不受影响。

 Sub RhidRow(ByVal count4 As Double, shtO As Object) 'count 4 is the total number of possible rows Dim count6, count1, count9 As Double 'counters to be used count6 = 2 'begin on row two count1 = 0 'check for visible rows counter With shtO While count6 < count4 DoEvents Application.StatusBar = "Checking row " & count6 & " of " & count4 & "." If Range("A" & CStr(count6)).EntireRow.Hidden = False Then count1 = count1 + 1 'if there was a visible row, then add one End If count6 = count6 + 1 'move to next row to check Wend Range("N7") = count6 'so I can hand check results If count1 = 0 Then 'if there were no visible rows, then set Z1 to 1 and exit the sub Range("Z1").Value = 1 'this is used to error check in another sub. if Z1 is 1, then the sheet is deleted Exit Sub End If count6 = 2 'start on row 2 count9 = 1 'count 9 While count9 < count4 'while the row is less than the count of the total rows DoEvents Application.StatusBar = "Deleting hidden rows. " & count6 & " or " & count9 & " of " & count4 & " done." If Range("A" & CStr(count6)).EntireRow.Hidden = True Then Range("A" & CStr(count6)).EntireRow.Delete 'if the row is hidden, delete it Else count6 = count6 + 1 'if it is not hidden, move to the next row End If count9 = count9 + 1 'show what row it is on in the status bar Wend End With End Sub 

Answer 1

也许这样的事情：

 Sub RhidRow(ByVal count4 As Double) 'count 4 should be a Long, not Double Dim count1 As Long 'counters to be used Dim ws As Worksheet Dim rngVis As Range Dim rngDel As Range Set ws = ActiveSheet On Error Resume Next Set rngVis = ws.Range("A2:A" & count4).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If rngVis Is Nothing Then ws.Range("Z1").Value = 1 Else For count1 = count4 To 2 Step -1 If ws.Rows(count1).Hidden = True Then If rngDel Is Nothing Then Set rngDel = ws.Rows(count1) Else Set rngDel = Union(rngDel, ws.Rows(count1)) End If End If Next count1 If Not rngDel Is Nothing Then Application.DisplayAlerts = False Intersect(rngDel, rngDel.ListObject.DataBodyRange).Delete 'if row is hidden, delete Application.DisplayAlerts = True End If End If End Sub 

Answer 2

这可能会更快一点：

 Sub RowKleaner() Dim rBig As Range, r As Range, rDelete As Range ActiveSheet.UsedRange Set rBig = Intersect(ActiveSheet.UsedRange, Range("A:A")) Set rDelete = Nothing For Each r In rBig If r.EntireRow.Hidden = True Then If rDelete Is Nothing Then Set rDelete = r Else Set rDelete = Union(rDelete, r) End If End If Next r If Not rDelete Is Nothing Then rDelete.EntireRow.Delete End If End Sub 

Answer 3

如果所有的行都被隐藏，下面的操作会删除工作表（或者我留下逻辑来决定），否则将只删除隐藏的行：

 Dim rngData As Range, rngVisible As Range, rngHidden As Range Set rngData = Range("C8:H20") Set rngVisible = rngData.SpecialCells(xlCellTypeVisible) Set rngHidden = Range("A:A") If (rngVisible Is Nothing) Then ' delete sheet or flag Else ' invert hidden / visible rngHidden.Rows.Hidden = False rngVisible.Rows.Hidden = True ' delete hidden and show visible rngData.SpecialCells(xlCellTypeVisible).Delete rngVisible.Rows.Hidden = False End If