VBA宏非常慢

目前我有一個完美運行的 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

uj5u.com熱心網友回復：

您對作業表的所有訪問確實會減慢速度。使用 VBA 陣列要快得多。

Range.Find您可以通過使用該方法確定是否存在重復的名稱Default來消除一些回圈Sheet1。

我們收集不重復的名稱（在一個集合中），然后創建一個陣列作為引數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

uj5u.com熱心網友回復：

嘗試添加這個，它通過關閉螢屏更新、事件、影片等來加速，這應該會加快一點！

在代碼的開頭添加這個子

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

uj5u.com熱心網友回復：

主要的減速是嵌套回圈。使用集合或字典進行更快的查找將使您的代碼加速 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

標籤：擅长vba

上一篇：回圈并列出問題

下一篇：在vba中打開Excel作業簿