Is there a faster way to cycle through my list?

Question

I have a list that is copied from one worksheet into a "calculation" sheet, and a second list that is copied from another worksheet into the same "calculation" sheet. Before my macro, I used a =VLOOKUP() formula to determine if each item had a match in the other list, and visa versa. Right now my code cycles item by item.

Is there a more efficient/time saving way to get the same outcome? (I have a copy of this sub for the counter comparison -- this is A > B, other is B > A)

Here's the code:

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

I tested with lists of 3000 values. Not sure if you're using it already but Application.ScreenUpdating = False should definitely be used (difference is 2500 ms to 220 ms for my test case). Aside from that, you can further optimize using something like the code below, which executes both comparisons in about 20 ms, saving you about 420 ms or almost 1/2 a second.

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

Answer 2

This:

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

would be better as:

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

Removing the select/activate is faster, and dropping the WorksheetFunction prevents the triggering of a run-time error if the Vlookup doesn't get a match