Excel VBA Code Instead of SumIf Array Formula for Unique Values

Hello excelforumkeys,

The macro below has been added to the attached workbook and is called by the command button. Placing the count next to each id is what slows the operation to a crawl. To speed things up I have the unique list and counts output to "Sheet2". All the data values are moved into RAM by using arrays. This eliminates the overhead encountered with Range objects. Try this out and let me know the results.

Sub Macro1()

    Dim Data    As Variant
    Dim DstWks  As Worksheet
    Dim Cnt     As Long
    Dim Key     As Variant
    Dim LastRow As Long
    Dim Rng     As Range
    Dim SrcWks  As Worksheet
    Dim Sums    As Object
   
        Set SrcWks = Worksheets("Sheet1")
        Set DstWks = Worksheets("Sheet2")
        
        Set Rng = SrcWks.Range("A2:B2")
        LastRow = SrcWks.Cells(Rows.Count, Rng.Column).End(xlUp).Row
        If LastRow < Rng.Row Then Exit Sub Else Set Rng = Rng.Resize(LastRow - Rng.Row + 1, 2)
        
            Set Sums = CreateObject("Scripting.Dictionary")
            Sums.CompareMode = vbCompare
            
            Data = Rng.Value
            
            For i = 1 To LastRow - Rng.Row + 1
                Key = Data(i, 1) & "|" & Data(i, 2)
                If Not Sums.Exists(Key) Then
                    Sums.Add Key, 1
                Else
                    Cnt = Sums(Key)
                    Sums(Key) = Cnt + 1
                End If
            Next i
            
            Cnt = 0
            ReDim Data(1 To Sums.Count, 1 To 3)
            
            For Each Key In Sums.Keys
                Cnt = Cnt + 1
                i = InStr(1, Key, "|")
                Data(Cnt, 1) = Left(Key, i - 1)
                Data(Cnt, 2) = Right(Key, Len(Key) - i)
                Data(Cnt, 3) = Sums(Key)
            Next Key
                
        Application.ScreenUpdating = False
            DstWks.UsedRange.Offset(1, 0).ClearContents
            DstWks.Cells(Rng.Row, Rng.Column).Resize(Cnt, 3).Value = Data
        Application.ScreenUpdating = True
        
End Sub