[RESOLVED] Counting pairs with their ID numbers code help

[Matten]

I have an excel file that counts pairs in a range of cells, their occurrences and list them in the result worksheet as Value1, Value2, Count. It is not useful for me this way.

In addition to Count, I need the ID Numbers of rows that those pairs happen together.

For example, if the Pair (A,B) has occurrence of 5, then the result should like this:
Value1 (A), Value2 (B), Count (5) and ID Numbers (ID1, ID2, ID3, ID4, ID5).

If the pair has occurrence of 7, then there should be ID Numbers.

This code works normally without ID numbers, but in the example file, I added ID Numbers shown in Yellow, and sample data in Blue color. So the code needs to distinguish ID numbers and the data, and treat them as such. Any help would be appreciated.

Here is the excel file link: https://1drv.ms/x/s!AoGkZUHlKui9gRWzqbBFZTJSIfiD

[westconn1]

most here prefer the workbooks to be attached to the post, zip first

can you post a result sheet of how you want it to appear, with correct result

[Matten]

CodePairs.zip

I am sorry, I tried to attach sample file in excel format, but it was not accepted, now I see I needed to zip first.
I changed the original file and added a worksheet named "Expected Results" with a little explanation. As long as there are ID numbers displayed, it is good for me. Please let me know if anything is unclear. thanks.

[westconn1]

i made a few changes to your posted code, i reduced the size of some of your arrays, which may solve some other problems
i added a 2nd dictionary to collect the ID numbers
i think it is working correctly, you will have to test

Sub CountForPairs()
    Dim cQ As cPair, dQ As Dictionary, dID As Dictionary
    Dim vSrc As Variant, vRes As Variant
    Dim I As Long, J As Long
    Dim wsData As Worksheet, wsRes As Worksheet, rRes As Range
    Dim V, W
    Dim sKey As String

Set wsData = Worksheets("Data")
Set wsRes = Worksheets("Results")
    Set rRes = wsRes.Cells(1, 10)

With wsData
    I = .Cells(.Rows.Count, 1).End(xlUp).Row 'Last Row
    J = .Cells(1, .Columns.Count).End(xlToLeft).Column 'Last Column
    vSrc = .Range(.Cells(1, 1), .Cells(I, J))
End With

Set dQ = New Dictionary
Set dID = New Dictionary
For I = 1 To UBound(vSrc, 1)

    'Size array for number of combos in each row
    V = Combos(Application.WorksheetFunction.Index(vSrc, I, 0))
    

    'create an object for each Quad, including each member, and the count
    For J = 1 To UBound(V, 1)
'    If V(J, 3) = 142 Then Stop
    Set cQ = New cPair
        With cQ
            .Q1 = V(J, 1)
            .Q2 = V(J, 2)
            .Cnt = 1
'            .ID = V(J, 3)
            sKey = Join(.Arr, Chr(1))

            'Add one to the count if Quad already exists
            If Not dQ.Exists(sKey) Then
                dQ.Add sKey, cQ
                dID.Add sKey, V(J, 3)
            Else
                If sKey = 40 & Chr(1) & 43 & Chr(1) Then Stop
                dQ(sKey).Cnt = dQ(sKey).Cnt + 1
                dID(sKey) = dID(sKey) & "," & V(J, 3)
            End If

        End With
    Next J
Next I

'Output the results
'set a threshold
Const TH As Long = 5

'Size the output array
I = 0
For Each V In dQ.Keys
    If dQ(V).Cnt >= TH Then I = I + 1
Next V
ReDim vRes(0 To I, 1 To 5)

'Headers
vRes(0, 1) = "Value 1"
vRes(0, 2) = "Value 2"
vRes(0, 3) = "Count"
vRes(0, 4) = "ID Number"
'Output the data
I = 0
For Each V In dQ.Keys
    Set cQ = dQ(V)
    With cQ
        If .Cnt >= TH Then
            I = I + 1
            vRes(I, 1) = .Q1
            vRes(I, 2) = .Q2
            vRes(I, 3) = .Cnt
            vRes(I, 4) = "'" & dID(V)
        End If
    End With
Next V

'Output the data
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
    .Sort key1:=.Columns(.Columns.Count), _
        order1:=xlDescending, Header:=xlYes, MatchCase:=False
End With
End Sub

Function Combos(Vals)
    Dim I As Long, J As Long, K As Long, M As Long
    Dim V
For I = 2 To UBound(Vals) - 1
    For J = I + 1 To UBound(Vals)
        M = M + 1
    Next J
Next I

ReDim V(1 To M, 1 To 3)
M = 0
For I = 2 To UBound(Vals) - 1
    For J = I + 1 To UBound(Vals)
      
                M = M + 1
                V(M, 1) = Vals(I)
                V(M, 2) = Vals(J)
                V(M, 3) = Vals(1)
                           
        Next J
Next I
Combos = V

End Function

[Matten]

I replaced the code on the module with your code keeping the class module same. When I run it on the sample data in the zip file, I got the following error.

Else
                If sKey = 40 & Chr(1) & 43 & Chr(1) Then Stop
                dQ(sKey).Cnt = dQ(sKey).Cnt + 1
                dID(sKey) = dID(sKey) & "," & V(J, 3)

"Stop" highlighted.

Should I make any change in the class module?

[westconn1]

sorry i just had that line for testing, when i was getting some erroneous results

just delete or comment out that line

Should I make any change in the class module?

no, i tried some changes there, but did not use any

[Matten]

Westconn1, This is perfect! Your code works way faster than before even with the Id numbers. Thanks a lot!

[westconn1]

are you sure the code actually does what you want?

it only pairs consecutive numbers from each row, not all combinations of pairs

[Matten]

I edited sorry.
yes, this is good for me. thanks.