performance - 加速删除工作表上隐藏行的代码

Question

下面我有一些我写的代码。它完全有效并且没有错误。但是，它非常非常慢。 sub 获取一张给定的带有表格的工作表并检查隐藏的行。如果所有行都被隐藏，它会删除工作表。如果没有，那么它会删除所有隐藏的行。

这是在另一个子系统中运行的，其中屏幕更新和事件等所有内容都被禁用。

我研究了加速代码的常用方法(这里: How to improve the speed of VBA macro code? ，这里: 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