excel - VBA 宏非常慢

Question

目前我有一个功能完美的 VBA 宏。做它需要做的一切。但是，我确实需要一些建议和帮助来加快这个宏的速度，因为它需要很长时间才能完成。此宏需要大约 5 分钟的时间来对大约 4k-5k 填充的行进行排序，然后它会隐藏一些行。

这个宏的工作原理是，它将对 A 列进行排序，对名称进行排序并将其与 Sheet1 中的列表进行比较，如果名称与 Sheet1 中的列表匹配，它将继续隐藏该行。提前致谢。

 Sub FilterNameDuplicate()
   Application.ScreenUpdating = False
 
    Dim iListCount As Integer
    Dim iCtr As Integer
    Dim a As Long
    Dim b As Long
    Dim c As Long
    Dim D As Long
    a = Worksheets("Default").Cells(Rows.Count, "G").End(xlUp).Row
For c = 1 To a
     b = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
        For D = 1 To b
            If StrComp(Worksheets("Sheet1").Cells(D, "A"), (Worksheets("Default").Cells(c, "G")), vbTextCompare) = 0 Then
                Worksheets("Default").Rows(c).EntireRow.Hidden = True
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    MsgBox "Done"
    End Sub

Answer 1

您对工作表的所有访问确实会减慢速度。使用 VBA 数组要快得多。

您可以通过使用 Range.Find 方法确定 Sheet1 中 Default 上是否存在重复名称来消除一些循环>.

我们收集非重复名称(在集合中)，然后创建一个数组用作 Range.Filter 方法的参数(这将有效地隐藏整行)。

因此:

使用 Match 函数编辑代码以更快地运行

Option Explicit
Sub FilterNameDuplicate()
    Dim ws1 As Worksheet, wsD As Worksheet
    Dim v1 As Variant, vD As Variant, r1 As Range, rD As Range
    Dim col As Collection
    Dim R As Range, I As Long, arrNames() As String

With ThisWorkbook
    Set ws1 = .Worksheets("Sheet1")
    Set wsD = .Worksheets("Default")
End With

With ws1
    Set r1 = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    v1 = r1
End With

With wsD
    Set rD = Range(.Cells(1, 7), .Cells(.Rows.Count, 7).End(xlUp))
    vD = rD
End With

'collect names on Default that are not on Sheet1
Set col = New Collection
With Application
    For I = 2 To UBound(vD, 1)
        If .WorksheetFunction.IsError(.Match(vD(I, 1), v1, 0)) Then col.Add vD(I, 1)
    Next I
End With

'Filter to include those names
Application.ScreenUpdating = False
If wsD.FilterMode Then wsD.ShowAllData

ReDim arrNames(1 To col.Count)
For I = 1 To col.Count
    arrNames(I) = col(I)
Next I

rD.AutoFilter field:=1, Criteria1:=arrNames, Operator:=xlFilterValues
End Sub