有沒有一種更快的方法來遍歷我的清單？

Question

我有一個列表，它從一個工作表復制到一個“計算”表，第二個列表，它從另一個工作表復制到相同的“計算”表。 在我的宏之前，我使用=VLOOKUP()公式來確定每個項目在另一個列表中是否都具有匹配項，反之亦然。 現在，我的代碼逐項循環。

有沒有更有效/省時的方法來獲得相同的結果？ （我有這個子的副本用於計數器比較-這是A> B，其他是B> A）

這是代碼：

Sub GPWireDifference()

'Establishes the Unmatched Great Plains Values list
    Set BWGPValues = New Dictionary


'Creates a variable to check if Keys already exist in list
    Dim lookup As String
    'Creates a variable to store the unmatched amount
    Dim amount As Currency
    'Sets a variable to count the amount of items in the checked list
    lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row


'Format all columns in the Calculation sheet to fit their contents
    Cells.EntireColumn.AutoFit
    'Formatting the numbers to the common "currency" type
    Range("B:E").NumberFormat = "$#,##0.00"
    Range("D2").Activate


'In the event of the value not matching, send the chain to a separate segment
    On Error GoTo ErrorHandler:


'Creates a loop to set the cell values to the results of the VLookup formula
    Do Until ActiveCell.Offset(0, -3).Value = ""
        ActiveCell.Value = Application.WorksheetFunction. _
            IfError(Application.WorksheetFunction. _
                VLookup(ActiveCell.Offset(0, -2), Range("C:C"), 1, False), 0)
        ActiveCell.Offset(1, 0).Activate
    Loop


'This error handler is to create a buffer so the macro doesn't lock itself into the
' error status... Unsure why, but if the buffer wasn't here, it breaks the code
ErrorHandler:
    If Not ActiveCell.Offset(0, -3).Value = "" Then
        GoTo ErrorHandler2:
    End If


'This error handler sets the Key and Item for the list, and stores the values
ErrorHandler2:
    If Not ActiveCell.Offset(0, -3).Value = "" Then
        lookup = ActiveCell.Offset(0, -3).Value
        amount = ActiveCell.Offset(0, -2).Value
        'Checks to see if the Key already exists. If so, sets the item value to the
        ' sum of the existing value and the new value
        If BWGPValues.Exists(lookup) Then
            BWGPValues(lookup) = BWGPValues(lookup) + amount
        Else 'If not, then it adds the key and the item values
            BWGPValues.Add lookup, amount
        End If
        Resume Next 'Returns to the loop
    End If


'Creates headers for the comparison rows
    Range("D1").Value = "GP to Wires:"
    Range("E1").Value = "Wires to GP:"


'Reformats the columns to fit all contents
    Cells.EntireColumn.AutoFit

End Sub

Answer 1

這個：

Do Until ActiveCell.Offset(0, -3).Value = ""
    ActiveCell.Value = Application.WorksheetFunction. _
        IfError(Application.WorksheetFunction. _
            VLookup(ActiveCell.Offset(0, -2), Range("C:C"), 1, False), 0)
    ActiveCell.Offset(1, 0).Activate
Loop

會更好：

Dim c As Range, res
Set c = Range("D2")

Do Until c.Offset(0, -3).Value = ""
    res = Application.VLookup(c.Offset(0, -2), Range("C:C"), 1, False)
    'if no match then res will contain an error, so test for that...
    c.Value = IIf(IsError(res), 0, res)

    Set c = c.Offset(1, 0)
Loop

刪除選擇/激活的速度更快，如果Vlookup找不到匹配項，則放下WorksheetFunction可以防止觸發運行時錯誤

Answer 2

我測試了3000個值的列表。 不知道您是否已經在使用它，但是絕對應該使用Application.ScreenUpdating = False（我的測試用例的差異是2500毫秒到220毫秒）。 除此之外，您可以使用下面的代碼來進一步優化，該代碼在大約20毫秒內執行兩次比較，從而節省了大約420毫秒或幾乎每秒1/2的時間。

Sub GPWireDifference()

'Prevent screen updating during execution
Application.ScreenUpdating = False

'Establishes the Unmatched Great Plains Values list
    Set BWGPValues = New Dictionary


'Creates a variable to check if Keys already exist in list
    Dim lookup As String
    'Creates a variable to store the unmatched amount
    Dim amount As Currency
    'Sets a variable to count the amount of items in the checked list
    lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row


'Format all columns in the Calculation sheet to fit their contents
    Cells.EntireColumn.AutoFit
    'Formatting the numbers to the common "currency" type
    Range("B:E").NumberFormat = "$#,##0.00"
    Range("D2").Activate

    'Place entire range in memory as array
    Dim A() As Variant: A = Range("B2:B" & lastRow).Value2
    'Create Dictionary to contain all unqiue values from list
    'The dictionary will store a collection of indexes for that unique value
    Dim Au As New Dictionary
    For i = 1 To UBound(A)
        If Not Au.Exists(A(i, 1)) Then
            Au.Add A(i, 1), New Collection
        End If
        Au(A(i, 1)).Add i
        A(i, 1) = ""
    Next

    'Repeat above steps for list B
    Dim B() As Variant: B = Range("C2:C" & lastRow).Value2
    Dim Bu As New Dictionary
    For i = 1 To UBound(B)
        If Not Bu.Exists(B(i, 1)) Then
            Bu.Add B(i, 1), New Collection
        End If
        Bu(B(i, 1)).Add i
        B(i, 1) = ""
    Next

    'Loop through unique values in A
    'If found in B's unique value list then populate B indexes with value
    For Each k In Au
        If Bu.Exists(k) Then
            For Each i In Bu(k)
                B(i, 1) = k
            Next
        End If
    Next

    'Loop through unique values in B
    'If found in A's unique value list then populate A indexes with value
    For Each k In Bu
        If Au.Exists(k) Then
            For Each i In Au(k)
                A(i, 1) = k
            Next
        End If
    Next

    'Assign Array back to Range
    Range("D2:D3000") = A
    Range("E2:E3000") = B

'Creates headers for the comparison rows
    Range("D1").Value = "GP to Wires:"
    Range("E1").Value = "Wires to GP:"


'Reformats the columns to fit all contents
    Cells.EntireColumn.AutoFit

End Sub