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

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