Find the most common combination of 3

S

SAE01

New Member
Joined
Oct 6, 2015
Messages
7
I have a worksheet containing 1000 rows of data. Each row has 6 columns, each cell contains a value of 1 - 100. For example:

630476388100
1733638898100
252644899096
6377888999100

<tbody>
</tbody>


The most common combination of the 3 numbers in this table is 63, 88, 100 because it occurs in rows 1, 2 and 4.

My data range is in Sheet 1, A1:F1000.

In Sheet 2, how can i get excel to show me the top 3 most common combinations, and the number of times they each occur? I was hoping to use a VBA solution rather than pivot tables or formulas.
 
Last edited:

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
Will a number ever be repeated on the same row?

Are the numbers always listed in ascending order Left to Right?
 
Upvote 0
Try this:-
Results sheet2
Code: 
[COLOR="Navy"]Sub[/COLOR] MG30Oct45
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Temp [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] ray [COLOR="Navy"]As[/COLOR] Variant, S [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Fst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Fin [COLOR="Navy"]As[/COLOR] Variant, oFst [COLOR="Navy"]As[/COLOR] Variant, nLst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oTem [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] nFst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] r [COLOR="Navy"]As[/COLOR] Variant, Sp [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Str [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] nST [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] sT [COLOR="Navy"]As[/COLOR] Variant, nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, K [COLOR="Navy"]As[/COLOR] Variant, nDn [COLOR="Navy"]As[/COLOR] Range, AcRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic2 [COLOR="Navy"]As[/COLOR] Object, num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]


[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]Set[/COLOR] Dic2 = CreateObject("scripting.dictionary")
Dic2.CompareMode = vbTextCompare
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] nDn [COLOR="Navy"]In[/COLOR] Rng
    Dic.RemoveAll
[COLOR="Navy"]Set[/COLOR] AcRng = nDn.Resize(, 6)
n = 0
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] AcRng
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        n = n + 1
        Dic.Add n, Dn.Value
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
c = 2
S = 0
ReDim ray(1 To Dic.Count)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys: S = S + 1: ray(S) = K
[COLOR="Navy"]Next[/COLOR] K


Str = Join(Application.Transpose(Application.Transpose(Dic.keys)), ",")
oTem = ray: nLst = Dic.Count
[COLOR="Navy"]Do[/COLOR] Until ray(1) = Str
   Temp = ray: c = 0
        [COLOR="Navy"]For[/COLOR] nn = 1 To UBound(Temp) - 1
            sT = Split(Temp(nn + 1), ",") '[COLOR="Green"][B]+1[/B][/COLOR]
              nST = IIf(UBound(sT) = 0, Temp(nn + 1), sT(UBound(sT)))
                 oFst = Split(Temp(nn), ",")
                    nFst = IIf(UBound(oFst) = 0, Temp(nn), oFst(UBound(oFst)))
                        [COLOR="Navy"]For[/COLOR] n = nST To nLst
                            [COLOR="Navy"]If[/COLOR] oTem(n) > nFst [COLOR="Navy"]Then[/COLOR]
                                c = c + 1
                                ReDim Preserve ray(1 To c)
                                ray(c) = Temp(nn) & "," & oTem(n)
                            [COLOR="Navy"]End[/COLOR] If
                        [COLOR="Navy"]Next[/COLOR] n
        [COLOR="Navy"]Next[/COLOR] nn
[COLOR="Navy"]If[/COLOR] Len(ray(1)) = 5 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(ray)
        [COLOR="Navy"]With[/COLOR] Range("A" & n).Offset(, 10)
            .NumberFormat = "@": Sp = Split(ray(n), ","): nStr = ""
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] r [COLOR="Navy"]In[/COLOR] Split(ray(n), ",")
                nStr = nStr & "," & Dic.Item(Val(r))
            [COLOR="Navy"]Next[/COLOR] r
                '[COLOR="Green"][B].Value = Mid(nStr, 2)[/B][/COLOR]
        [COLOR="Navy"]If[/COLOR] Not Dic2.exists(Mid(nStr, 2)) [COLOR="Navy"]Then[/COLOR]
            Dic2.Add Mid(nStr, 2), 1
        [COLOR="Navy"]Else[/COLOR]
            Dic2(Mid(nStr, 2)) = Dic2(Mid(nStr, 2)) + 1
        [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Loop[/COLOR]
[COLOR="Navy"]Next[/COLOR] nDn


[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic2.keys
    [COLOR="Navy"]If[/COLOR] Dic2(K) > num [COLOR="Navy"]Then[/COLOR]
        Temp = K
        num = Dic2(K)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    .Range("A1") = Temp
    .Range("B1") = num
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi,

I have assumed that you need to see only the values associated with the largest count.
I have also assumed that several keys might have the same count.

Code: 
Sub TrioMax()

    Dim i As Long, j As Long, k As Long, l As Long
    Dim lr As Long, iMax As Long
    Dim Dic As Object, Key As String, Arr As Variant
    Dim Col As Collection, c As Variant

    Set Dic = CreateObject("Scripting.Dictionary")
    Set Col = New Collection
    
    ' Read In Data
    With ThisWorkbook.Worksheets("Sheet1")
        Arr = .Range("A1:F" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With
    
    ' Process Data
    For i = 1 To UBound(Arr)
        For j = 1 To 4
            For k = j + 1 To 5
                For l = k + 1 To 6
                    Key = Arr(i, j) & "," & Arr(i, k) & "," & Arr(i, l)
                    Dic(Key) = Dic(Key) + 1
                    If iMax < Dic(Key) Then
                        Set Col = New Collection
                        iMax = Dic(Key)
                    End If
                    If iMax = Dic(Key) Then Col.Add Key
                Next
            Next
        Next
    Next
    
    ' Output Data
    With ThisWorkbook.Worksheets("Sheet2")
        .Columns("A:B").Clear
        For i = 1 To Col.Count
            .Cells(i, 1) = Col(i)
            .Cells(i, 2) = iMax
        Next
    End With

End Sub
The data is copied into an array to speed up processing (Arr).
Then the possible permutations are combined into a key (Key).
These keys are written to a Dictionary object (Dic). This can recognise duplicates and increments a counter if one is found.
As new maximum counts are found so a Collection is used to save the keys (Col).
If a new maximum count is found then the old Collection is cleared and the key accumulation starts again.
Finally, the collection, which now contains the most frequent keys, is written to sheet2.
 
Upvote 0
Jerry,

There will never be repeated numbers in a row, and the number will always be listed in ascending order.
 
Upvote 0
Looks like Mick and Rick's suggestions will work. The approach Rick took is close to what I had in mind. That seems more direct to me than Mick's approach- but Mick can respond if his code is doing something necessary that Rick's code does not include.

SAE01 said:
In Sheet 2, how can i get excel to show me the top 3 most common combinations, and the number of times they each occur?
Click to expand...

It sounds like you wanted the top 3 combinations instead of just the top one. If that's correct, then perhaps Mick and/or Rick could modify their code slightly to report all 3.
 
Upvote 0
RickXL said:
Hi,

I have assumed that you need to see only the values associated with the largest count.
I have also assumed that several keys might have the same count.

Code: 
Sub TrioMax()

    Dim i As Long, j As Long, k As Long, l As Long
    Dim lr As Long, iMax As Long
    Dim Dic As Object, Key As String, Arr As Variant
    Dim Col As Collection, c As Variant

    Set Dic = CreateObject("Scripting.Dictionary")
    Set Col = New Collection
   
    ' Read In Data
    With ThisWorkbook.Worksheets("Sheet1")
        Arr = .Range("A1:F" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With
   
    ' Process Data
    For i = 1 To UBound(Arr)
        For j = 1 To 4
            For k = j + 1 To 5
                For l = k + 1 To 6
                    Key = Arr(i, j) & "," & Arr(i, k) & "," & Arr(i, l)
                    Dic(Key) = Dic(Key) + 1
                    If iMax < Dic(Key) Then
                        Set Col = New Collection
                        iMax = Dic(Key)
                    End If
                    If iMax = Dic(Key) Then Col.Add Key
                Next
            Next
        Next
    Next
   
    ' Output Data
    With ThisWorkbook.Worksheets("Sheet2")
        .Columns("A:B").Clear
        For i = 1 To Col.Count
            .Cells(i, 1) = Col(i)
            .Cells(i, 2) = iMax
        Next
    End With

End Sub
The data is copied into an array to speed up processing (Arr).
Then the possible permutations are combined into a key (Key).
These keys are written to a Dictionary object (Dic). This can recognise duplicates and increments a counter if one is found.
As new maximum counts are found so a Collection is used to save the keys (Col).
If a new maximum count is found then the old Collection is cleared and the key accumulation starts again.
Finally, the collection, which now contains the most frequent keys, is written to sheet2.
Click to expand...
I have a spreadsheet with 518 rows and 7 columns. The first column has a date and the first row is a header. I tried the above codes but I am getting "Run-time error '9': Subscript out of range".
I have changed the range, but still getting the same error message.
 
Upvote 0
RickXL said:
Hi,

I have assumed that you need to see only the values associated with the largest count.
I have also assumed that several keys might have the same count.

Code: 
Sub TrioMax()

    Dim i As Long, j As Long, k As Long, l As Long
    Dim lr As Long, iMax As Long
    Dim Dic As Object, Key As String, Arr As Variant
    Dim Col As Collection, c As Variant

    Set Dic = CreateObject("Scripting.Dictionary")
    Set Col = New Collection
   
    ' Read In Data
    With ThisWorkbook.Worksheets("Sheet1")
        Arr = .Range("A1:F" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With
   
    ' Process Data
    For i = 1 To UBound(Arr)
        For j = 1 To 4
            For k = j + 1 To 5
                For l = k + 1 To 6
                    Key = Arr(i, j) & "," & Arr(i, k) & "," & Arr(i, l)
                    Dic(Key) = Dic(Key) + 1
                    If iMax < Dic(Key) Then
                        Set Col = New Collection
                        iMax = Dic(Key)
                    End If
                    If iMax = Dic(Key) Then Col.Add Key
                Next
            Next
        Next
    Next
   
    ' Output Data
    With ThisWorkbook.Worksheets("Sheet2")
        .Columns("A:B").Clear
        For i = 1 To Col.Count
            .Cells(i, 1) = Col(i)
            .Cells(i, 2) = iMax
        Next
    End With

End Sub
The data is copied into an array to speed up processing (Arr).
Then the possible permutations are combined into a key (Key).
These keys are written to a Dictionary object (Dic). This can recognise duplicates and increments a counter if one is found.
As new maximum counts are found so a Collection is used to save the keys (Col).
If a new maximum count is found then the old Collection is cleared and the key accumulation starts again.
Finally, the collection, which now contains the most frequent keys, is written to sheet2.
Click to expand...
Hello Rick, can this be edited to list all of the combinations of the 3 numbers that appear more than once? Thank you for your help.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question
conditional formatting question
Replies
2
Views
179
kerm007
K
N
  • Question
Finding most common number in a range
2
Replies
14
Views
389
Peter_SSs
Peter_SSs
W
  • Locked
  • Question
How to find the most frequent combination.
Replies
2
Views
125
Peter_SSs
Peter_SSs
W
  • Question
How to find the most frequent combination in a dataset.
2 3
Replies
24
Views
528
Cubist
Cubist
togenmoser
  • Solved
Finding all possible combinations of 2 sums
2
Replies
10
Views
247
togenmoser
togenmoser

Forum statistics

Threads
1,215,391
Messages
6,124,674
Members
449,179
Latest member
fcarfagna

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top