对4k-5k行进行排序，以隐藏某些行

Question

如何加快VBA代码的运行速度？在4k-5k行中进行排序，隐藏一些行需要很长时间，大约五分钟。

宏对列A进行排序，对名称进行排序，并将其与Sheet1中的列表进行比较。如果名称与图纸1中的列表匹配，则会隐藏该行。

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上的名称是否重复，从而消除一些循环。

我们收集不重复的名称(在Collection中(，然后创建一个数组用作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

Answer 2

主要的减速是对嵌套循环执行操作。使用集合或字典进行更快的查找将使代码加速100倍。

Sub FilterNameDuplicate()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Rem Unhide all the rows
Worksheets("Default").UsedRange.EntireRow.Hidden = False

Dim Keys As Collection
Set Keys = GKeys

Dim Key As String

Dim Target As Range

With Worksheets("Default")
Set Target = Intersect(.UsedRange, .Columns("G"))
End With

If Target Is Nothing Then
MsgBox "Invalid Range"
Exit Sub
End If

Dim Cell As Range
For Each Cell In Target
Key = UCase(Cell.Value)
On Error Resume Next
Key = Keys(Key)
Cell.EntireRow.Hidden = Err.Number <> 0
On Error GoTo 0
Next

Rem We no longer need to turn ScreenUpdating back on
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
End Sub
Function GKeys() As Collection
Set GKeys = New Collection
Dim Key As String

Dim Data As Variant
Data = Worksheets("Sheet1").Range("A1").CurrentRegion.Columns(1).Value

Dim r As Long

For r = 1 To UBound(Data)
Key = UCase(Data(r, 1))
On Error Resume Next
GKeys.Add Key:=Key, Item:=""
On Error GoTo 0
Next

End Function

Answer 3

尝试在其中添加，它可以通过关闭屏幕更新、事件、动画等来加快速度，这应该会加快一点！

在您的代码开始时，添加到此子

Call TurnOffCode

在您的代码末尾添加到此子

Call TurnOnCode

这就是他们应该看起来都像

Sub TurnOffCode() 'Used to turn off settings to make workbook run faster
Application.Calculation = xlCalculationManual 'Set calculations to manual
Application.ScreenUpdating = False 'Turns off screen updating
Application.EnableEvents = False 'Turns off events
Application.EnableAnimations = False 'Turns off animations
Application.DisplayStatusBar = False 'Turns off display status bar
Application.PrintCommunication = False 'Turns off print communications
End Sub
Sub TurnOnCode() 'Used to turn settings back on to normal
Application.Calculation = xlCalculationAutomatic 'Set calculations to automatic
Application.ScreenUpdating = True 'Turns on screen updating
Application.EnableEvents = True 'Turns on events
Application.EnableAnimations = True 'Turns on animations
Application.DisplayStatusBar = True 'Turns on display status bar
Application.PrintCommunication = True 'Turns on print communications
End Sub