Question

下面我有一些我写过的代码。它是完全有效的，没有错误。但是，它非常非常慢。子获取一个给定的表，上面有一个表，并检查隐藏的行。如果隐藏了所有行，则会删除工作表。如果没有，则删除所有隐藏的行。

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

我研究了加速代码的常用方法（此处：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

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

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

3 个答案: