VBA: Nested Loops and Knowing How Many Times it's Looped

Question

    Dim pos As Range, range1 As Range, range2 As Range
    Dim x As Variant, Y As Variant
    
    Set pos = Sheets("Sheet1").Cells(5, 6)
    For Each y In range1
        Set pos = pos.Offset(3, 0)                'Currently setting 3 spaces between each change of Y
        For Each x In range2
            If y = x Then
                x.Cells(, 5).Copy pos
                Set pos = pos.Offset(1, 0)
            End If
        Next x
    Next y

Instead of putting spaces of 3, I want to know how many times X is copied for each time that Y changes, how would you do this? I was thinking a counter, but how would you reset it?

Answer 1

Counting Using an Array or a Dictionary

• All solutions are case-insensitive, i.e. A=a.
• These are 3 pairs of solutions where each first is using a second loop, while each second is using Application.CountIf as a more efficient way instead.
• The second pair (solutions 3 and 4) should be the most efficient, but can only be used if the values in range1 are unique, while the others can be used in any case, the first pair (solutions 1 and 2) probably being more efficient.
• Also consider the differences between retrieving the values from the array and retrieving the values from the dictionary.

The Code

Option Explicit

Sub testUniqueDictionaryLoop()
    
    Dim range1 As Range: Set range1 = Range("D2:D11")
    Dim range2 As Range: Set range2 = Range("F2:H11")
    Dim y As Range
    Dim x As Range
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    For Each y In range1.Cells
        If Not dict.Exists(y.Value) Then
            dict(y.Value) = 0
            For Each x In range2.Cells
                If StrComp(x.Value, y.Value, vbTextCompare) = 0 Then
                    dict(y.Value) = dict(y.Value) + 1
                End If
            Next x
        End If
    Next y
    
    ' Write to the Immediate window.
    Dim Key As Variant
    For Each Key In dict.keys
        Debug.Print Key, dict(Key)
    Next Key

    ' Write to a two-column range.
    With Range("A2").Resize(, 2)
        .Resize(Rows.Count - .Row + 1).ClearContents
        .Columns(1).Resize(dict.Count).Value = Application.Transpose(dict.keys)
        .Columns(2).Resize(dict.Count).Value = Application.Transpose(dict.Items)
    End With

End Sub

Sub testUniqueDictionaryCountIf()
    
    Dim range1 As Range: Set range1 = Range("D2:D11")
    Dim range2 As Range: Set range2 = Range("F2:H11")
    Dim y As Range
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    For Each y In range1.Cells
        If Not dict.Exists(y.Value) Then
            dict(y.Value) = Application.CountIf(range2, y.Value)
        End If
    Next y
    
    ' Write to the Immediate window.
    Dim Key As Variant
    For Each Key In dict.keys
        Debug.Print Key, dict(Key)
    Next Key

    ' Write to a two-column range.
    With Range("A2").Resize(, 2)
        .Resize(Rows.Count - .Row + 1).ClearContents
        .Columns(1).Resize(dict.Count).Value = Application.Transpose(dict.keys)
        .Columns(2).Resize(dict.Count).Value = Application.Transpose(dict.Items)
    End With
   
End Sub

Sub testArrayLoop()
    
    Dim range1 As Range: Set range1 = Range("D2:D11")
    Dim range2 As Range: Set range2 = Range("F2:H11")
    Dim y As Range
    Dim x As Range

    Dim Data As Variant: ReDim Data(1 To range1.Cells.CountLarge, 1 To 2)
    
    Dim i As Long
    
    For Each y In range1.Cells
        i = i + 1
        Data(i, 1) = y.Value
        Data(i, 2) = 0
        For Each x In range2.Cells
            If StrComp(x.Value, y.Value, vbTextCompare) = 0 Then
                Data(i, 2) = Data(i, 2) + 1
            End If
        Next x
    Next y
    
    ' Write to the Immediate window.
    For i = 1 To UBound(Data, 1)
        Debug.Print Data(i, 1), Data(i, 2)
    Next i

    ' Write to a two-column range.
    With Range("A2").Resize(, 2)
        .Resize(Rows.Count - .Row + 1).ClearContents
        .Resize(UBound(Data, 1)).Value = Data
    End With

End Sub

Sub testArrayCountIf()
    
    Dim range1 As Range: Set range1 = Range("D2:D11")
    Dim range2 As Range: Set range2 = Range("F2:H11")
    Dim y As Range
    Dim x As Range

    Dim Data As Variant: ReDim Data(1 To range1.Cells.CountLarge, 1 To 2)
    
    Dim i As Long
    
    For Each y In range1.Cells
        i = i + 1
        Data(i, 1) = y.Value
        Data(i, 2) = Application.CountIf(range2, Data(i, 1))
    Next y
    
    ' Write to the Immediate window.
    For i = 1 To UBound(Data, 1)
        Debug.Print Data(i, 1), Data(i, 2)
    Next i

    ' Write to a two-column range.
    With Range("A2").Resize(, 2)
        .Resize(Rows.Count - .Row + 1).ClearContents
        .Resize(UBound(Data, 1)).Value = Data
    End With

End Sub

Sub testUniqueArrayLoop()
    
    Dim range1 As Range: Set range1 = Range("D2:D11")
    Dim range2 As Range: Set range2 = Range("F2:H11")
    Dim y As Range
    Dim x As Range

    Dim Data As Variant: ReDim Data(1 To range1.Cells.CountLarge, 1 To 2)
    
    Dim i As Long
    
    For Each y In range1.Cells
        If IsError(Application.Match(y.Value, Data, 0)) Then
            i = i + 1
            Data(i, 1) = y.Value
            Data(i, 2) = 0
            For Each x In range2.Cells
                If StrComp(x.Value, y.Value, vbTextCompare) = 0 Then
                    Data(i, 2) = Data(i, 2) + 1
                End If
            Next x
        End If
    Next y
    
    Dim k As Long: k = i
    
    ' Write to the Immediate window.
    For i = 1 To k
        Debug.Print Data(i, 1), Data(i, 2)
    Next i

    ' Write to a two-column range.
    With Range("A2").Resize(, 2)
        .Resize(Rows.Count - .Row + 1).ClearContents
        .Resize(k).Value = Data
    End With

End Sub

Sub testUniqueArrayCountIf()
    
    Dim range1 As Range: Set range1 = Range("D2:D11")
    Dim range2 As Range: Set range2 = Range("F2:H11")
    Dim y As Range
    Dim x As Range

    Dim Data As Variant: ReDim Data(1 To range1.Cells.CountLarge, 1 To 2)
    
    Dim i As Long
    
    For Each y In range1.Cells
        If IsError(Application.Match(y.Value, Data, 0)) Then
            i = i + 1
            Data(i, 1) = y.Value
            Data(i, 2) = Application.CountIf(range2, Data(i, 1))
        End If
    Next y
    
    Dim k As Long: k = i
    
    ' Write to the Immediate window.
    For i = 1 To k
        Debug.Print Data(i, 1), Data(i, 2)
    Next i

    ' Write to a two-column range.
    With Range("A2").Resize(, 2)
        .Resize(Rows.Count - .Row + 1).ClearContents
        .Resize(k).Value = Data
    End With

End Sub

Answer 2

I made a collection object that will add a new counter for every y. In the second loop it increments the last element of the collection by one. At the end if you look at each element in the collection it should contain the number of times x=y per y element.

Dim pos As Range
Dim range1 As Range
Dim range2 As Range
Dim x As Range
Dim y As Range
Dim countXinY As New Collection

Set pos = Sheets("Sheet1").Cells(5, 6)
For Each y In range1
    countXinY.Add 0
    Set pos = pos.Offset(3, 0)                'Currently setting 3 spaces between each change of Y
    For Each x In range2
        If y = x Then
            countXinY(countXinY.Count) = countXinY(countXinY.Count) + 1
            x.Cells(, 5).Copy pos
            Set pos = pos.Offset(1, 0)
        End If
    Next x
Next y