' This code is for early binding; set reference to Microsoft Scripting Runtime library
 
Option Explicit
 
Private Sub CompareObjects()
    
    ' This sub actually runs the tests
    
    Dim coll As Collection
    Dim dic As Scripting.Dictionary
    Dim Counter As Long
    Dim RowCounter As Long
    Dim ColCounter As Long
    Dim StartCollection As Date
    Dim EndCollection As Date
    Dim StartDicAdd As Date
    Dim EndDicAdd As Date
    Dim StartDicItem As Date
    Dim EndDicItem As Date
    Dim StartDicExists As Date
    Dim EndDicExists As Date
    Dim arr As Variant
    Dim Results() As Long
    Dim oRow As ListRow
    
    Const Iterations As Long = 20
    Const NumRows As Long = 10000
    Const NumCols As Long = 50
    
    With ThisWorkbook.Worksheets("Test Data")
        
        'Remove rows with distinct values written to them
 
        .Range((NumRows + 1) & ":" & .Rows.Count).Delete
        
        StartCollection = Now
    
        ' Repeat the test several times to smooth out random fluctuations
 
        For Counter = 1 To Iterations
            For ColCounter = 1 To NumCols
 
                ' Create Collection
 
                Set coll = New Collection
 
                ' Array transfer to speed up process
 
                arr = .Cells(1, ColCounter).Resize(NumRows, 1).Value
 
                ' If you attempt to add an item where the key already exists, an error results
 
                On Error Resume Next
                For RowCounter = 1 To NumRows
                    coll.Add arr(RowCounter, 1), CStr(arr(RowCounter, 1))
                Next
                On Error GoTo 0
 
                ' Build an array with the return values and write them to worksheet
 
                ReDim Results(1 To coll.Count, 1 To 1)
                For RowCounter = 1 To coll.Count
                    Results(RowCounter, 1) = coll(RowCounter)
                Next
                .Cells(NumRows + 2, ColCounter).Resize(UBound(arr, 1), 1).Value = Results
                Set coll = Nothing
            Next
        Next
        
        EndCollection = Now
        
        .Range((NumRows + 1) & ":" & .Rows.Count).Delete
        
        StartDicAdd = Now
    
        For Counter = 1 To Iterations
            For ColCounter = 1 To NumCols
 
                ' Create Dictionary
 
                Set dic = New Scripting.Dictionary
                arr = .Cells(1, ColCounter).Resize(NumRows, 1).Value
 
                ' If you attempt to add an item where the key already exists, an error results
 
                On Error Resume Next
                For RowCounter = 1 To NumRows
                    dic.Add arr(RowCounter, 1), arr(RowCounter, 1)
                Next
                On Error GoTo 0
 
                ' Put keys into an array, and write array values to worksheet
 
                arr = dic.Keys
                .Cells(NumRows + 2, ColCounter).Resize(dic.Count, 1).Value = Application.Transpose(arr)
                Set dic = Nothing
            Next
        Next
        
        EndDicAdd = Now
        
        .Range((NumRows + 1) & ":" & .Rows.Count).Delete
        
        StartDicItem = Now
    
        For Counter = 1 To Iterations
            For ColCounter = 1 To NumCols
                Set dic = New Scripting.Dictionary
                arr = .Cells(1, ColCounter).Resize(NumRows, 1).Value
 
                ' In this approach, we use the Item property's "implicit add" capability.  Within
                ' the loop, the Item property either reassigns the item to the key (albeit to same value
                ' if the key already exists, or creates a new key/item pair if not
 
                For RowCounter = 1 To NumRows
                    dic.Item(arr(RowCounter, 1)) = arr(RowCounter, 1)
                Next
                arr = dic.Keys
                .Cells(NumRows + 2, ColCounter).Resize(dic.Count, 1).Value = Application.Transpose(arr)
                Set dic = Nothing
            Next
        Next
        
        EndDicItem = Now
        
        .Range((NumRows + 1) & ":" & .Rows.Count).Delete
        
        StartDicExists = Now
    
        For Counter = 1 To Iterations
            For ColCounter = 1 To NumCols
                Set dic = New Scripting.Dictionary
                arr = .Cells(1, ColCounter).Resize(NumRows, 1).Value
 
                ' In this approach, we test for existence first; if the key does not exist, we add the item
 
                For RowCounter = 1 To NumRows
                    If Not dic.Exists(arr(RowCounter, 1)) Then
                        dic.Add arr(RowCounter, 1), arr(RowCounter, 1)
                    End If
                Next
                arr = dic.Keys
                .Cells(NumRows + 2, ColCounter).Resize(dic.Count, 1).Value = Application.Transpose(arr)
                Set dic = Nothing
            Next
        Next
        
        EndDicExists = Now
        
    End With
    
    ' For each of the four approaches, write a record to the Results worksheet
 
    With ThisWorkbook.Worksheets("Results")
        Set oRow = .ListObjects("Stats").ListRows.Add(AlwaysInsert:=True)
        oRow.Range(1, 1) = StartCollection
        oRow.Range(1, 2) = "Collection"
        oRow.Range(1, 3) = EndCollection - StartCollection
        Set oRow = .ListObjects("Stats").ListRows.Add(AlwaysInsert:=True)
        oRow.Range(1, 1) = StartCollection
        oRow.Range(1, 2) = "Dictionary Add"
        oRow.Range(1, 3) = EndDicAdd - StartDicAdd
        Set oRow = .ListObjects("Stats").ListRows.Add(AlwaysInsert:=True)
        oRow.Range(1, 1) = StartCollection
        oRow.Range(1, 2) = "Dictionary Item"
        oRow.Range(1, 3) = EndDicItem - StartDicItem
        Set oRow = .ListObjects("Stats").ListRows.Add(AlwaysInsert:=True)
        oRow.Range(1, 1) = StartCollection
        oRow.Range(1, 2) = "Dictionary Exists"
        oRow.Range(1, 3) = EndDicExists - StartDicExists
    End With
        
End Sub

Sub CompareObjectsMulti()
    
    ' Use this to run the test multiple times
 
    Dim Iterations As Long
    Dim Counter As Long
    
    On Error GoTo ErrHandler
    
    Iterations = InputBox("How many trials do you want (each can take 2-4 minutes)", "Compare", 10)
    
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    For Counter = 1 To Iterations
        CompareObjects
    Next
    
ErrHandler:
    
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    
    MsgBox "Done"
    
End Sub

Sub CompareObjectsSingle()
    
    ' Use this to run the test one time
 
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    CompareObjects
    
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    
    MsgBox "Done"
    
End Sub

Select all