Most common combinations in a worksheet

D

DeasBg

New Member
Joined
Mar 12, 2018
Messages
5
Hi
I found this earlier post about finding the most common combinations of 3 in a worksheet:

https://www.mrexcel.com/forum/excel-questions/898307-find-most-common-combination-3-a.html

I have a similar problem, but instead of 6 coloums and combinations of 3, I have 20 coloums and want to find combinations of 10.
I've tried to change both the macros given in the other post, but my knowledge of macros are very basic so it gets wrong every time I try.

Can anyone help me rewrite either of the macros so it will work for my situation?
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Try this:-
If not what you want, you will need to explain further !!
Code: 
[COLOR="Navy"]Sub[/COLOR] MG12Mar25
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = ActiveSheet.Cells(1).CurrentRegion.Resize(, 20)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
    .Add Dn.Value, 1
[COLOR="Navy"]Else[/COLOR]
    .Item(Dn.Value) = .Item(Dn.Value) + 1
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]If[/COLOR] .Item(K) = 10 [COLOR="Navy"]Then[/COLOR]
        nStr = nStr & IIf(nStr = "", K, ", " & K)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
MsgBox "Duplicate value of size 10 :- " & nStr
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick
I have, like in the other post I was referring to, a worksheet containing about 3000 rows of data. Each row has 20 columns, and I want to find the most common combination of 10 numbers.

Example with 4 rows where the most common combination in this case would be the numbers 101-110, because they all occur in row 1, 3 and 4:
1101102103104105106107108109110232527293133353739
246810121416182022242628303234363840
41434547495153551011021031041051061071081091107779
42444648505254565860101102103104105106107108109110

<tbody>
</tbody>


I see you made the following code to the other post I was referring to. I tried it and it works when its 6 columns and you want to find the most common combination of 3 numbers. So I want to change that code so I can use it for my case with 20 columns and to find the most common combination of 10 numbers.

Code: 
Sub MG30Oct45()
Dim Rng As Range, Dn As Range, Temp As Variant, c As Long, n As Long, nn As Long
Dim ray As Variant, S As Long
Dim Fst As Long, Fin As Variant, oFst As Variant, nLst As Long, oTem As Variant
Dim nFst As Long, r As Variant, Sp As Variant
Dim Str As String, nST As Long, sT As Variant, nStr As String
Dim Dic As Object, K As Variant, nDn As Range, AcRng As Range
Dim Dic2 As Object, num As Long

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

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

For Each K In Dic2.keys
    If Dic2(K) > num Then
        Temp = K
        num = Dic2(K)
    End If
Next K
With Sheets("Sheet2")
    .Range("A1") = Temp
    .Range("B1") = num
End With
End Sub
 
Upvote 0
Try this:-
Code: 
[COLOR=navy]Sub[/COLOR] MG13Mar14
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Temp [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] K [COLOR=navy]As[/COLOR] Variant, Num [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] nTemp [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] s [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Sp [COLOR=navy]As[/COLOR] Variant, R [COLOR=navy]As[/COLOR] Variant, m [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = ActiveSheet.Cells(1).CurrentRegion.Resize(, 20)
ReDim nStr(1 To Rng.Count) [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]If[/COLOR] Temp = 0 Or Not Temp + 1 = Dn.Value [COLOR=navy]Then[/COLOR]
        Temp = Dn.Value
        c = c + 1
        nStr(c) = Temp
    [COLOR=navy]ElseIf[/COLOR] Temp + 1 = Dn.Value [COLOR=navy]Then[/COLOR]
        nStr(c) = nStr(c) & ", " & Dn.Value
        Temp = Dn.Value
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]

With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] n = 1 To c
    Sp = Split(nStr(n), ", ")
    [COLOR=navy]If[/COLOR] UBound(Sp) = 9 [COLOR=navy]Then[/COLOR]
        [COLOR=navy]If[/COLOR] Not .Exists(nStr(n)) [COLOR=navy]Then[/COLOR]
            .Add nStr(n), 1
        [COLOR=navy]Else[/COLOR]
            .Item(nStr(n)) = .Item(nStr(n)) + 1
           [COLOR=navy]If[/COLOR] .Item(nStr(n)) >= Num [COLOR=navy]Then[/COLOR] Num = .Item(nStr(n))
        [COLOR=navy]End[/COLOR] If
  [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] n
 
 [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    [COLOR=navy]If[/COLOR] .Item(K) = Num [COLOR=navy]Then[/COLOR]
        s = s + 1
        nTemp = nTemp & vbLf & K
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] K
MsgBox "Largest Run of 10 Numbers = " & Num & vbLf & "Number String = " & nTemp
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
Hi again.
I tried the code and it works when the numbers are consecutive. Maybe my example above was confusing, and I didn't say that the numbers can be in any random order.
The numbers can be sorted ascending.

This works:
61
62
63
64
65
66
67
68
69
70
47
4
15
16
33
8
28
26
41
1
91
110
99
89
83
71
102
56
50
88
61
62
63
64
65
66
67
68
69
70

<tbody>
</tbody>

But the code doesn't work for this situation:
1
3
4
8
9
11
16
19
22
26
34
38
40
41
44
58
61
62
69
70
2
4
7
9
10
12
15
19
22
26
35
38
39
41
44
58
60
65
68
70

<tbody>
</tbody>
 
Upvote 0
So to recap:-
Would it be right to say you want, the/Any ten numbers from any single row, that repeat themselves the maximum number of times in any of the other rows.

If so, do they need to be (not in the same relative cells), but in the same order ???
so in your example above would it be acceptable to have the first and second line as below:-
1348911____
29741012____

<tbody>
</tbody>
 
Last edited:
Upvote 0
I suspect your requirements are practically unsolvable. Even on one row, there are 184,756 different ways to choose 10 numbers from the 20 available. You're going to crash VBA trying to work with such large and complex calculations.

WBD
 
Upvote 0
I also share doubts about how practical this is. However, I found it interesting, so I wrote up this code:

Rich (BB code): 
Sub FindMaxPatterns()
Dim MyDict As Variant, z() As Long, ix() As Byte
Dim i As Long, j As Long, r As Long, MyData As Variant
Dim MyMax As Long, Results As Object, NumItems As Long, NumSet As Long
    
    NumItems = 20
    NumSet = 10
    
    ReDim z(1 To NumItems)
    ReDim ix(1 To NumItems)
    
    Set MyDict = CreateObject("Scripting.Dictionary")
    Set Results = CreateObject("Scripting.Dictionary")
    MyData = Sheets("Sheet8").Range("A1").Resize(Sheets("Sheet8").Cells(Rows.Count, "A").End(xlUp).Row, NumItems).Value
    MyMax = -1
    
    For r = 1 To UBound(MyData)
        For i = 1 To NumItems
            z(i) = MyData(r, i)
        Next i
        Call QuickSort(z, 1, NumItems)
        For i = 0 To 2 ^ NumItems - 1
            If WorksheetFunction.Sum(ix) = NumSet Then
                str1 = ""
                For j = 1 To NumItems
                    If ix(j) = 1 Then str1 = str1 & z(j) & "."
                Next j
                MyDict(str1) = MyDict(str1) + 1
                If MyDict(str1) > MyMax Then
                    MyMax = MyDict(str1)
                    Results.RemoveAll
                End If
                If MyDict(str1) = MyMax Then Results(str1) = 1
            End If
            
            For j = 1 To NumItems
                ix(j) = ix(j) + 1
                If ix(j) = 1 Then Exit For
                ix(j) = 0
            Next j
        Next i
        
    Next r
            
    Sheets("Sheet9").Range("A1") = MyMax
    Sheets("Sheet9").Range("B1").Resize(Results.Count) = WorksheetFunction.Transpose(Results.keys)
    
End Sub


Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)


  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long


  tmpLow = inLow
  tmpHi = inHi


  pivot = vArray((inLow + inHi) \ 2)


  While (tmpLow <= tmpHi)


     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend


     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend


     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If


  Wend


  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi


End Sub

The quicksort code I gathered from the internet. This assumes that the data starts in A1, and is NumItems columns wide. Change the items in red to match your sheet. I tested this on a fast computer. With only 3 lines of data, it took 16 seconds. You do the math as to how long your data will take. And you may well run out of RAM. Let us know if this works for you.
 
Last edited:
Upvote 0
This version runs faster since I removed a worksheet function call. 3 lines in 6 seconds now. But the storage requirements remain.

Code: 
Sub FindMaxPatterns()
Dim MyDict As Variant, z() As Long, ix() As Byte, ctr As Byte
Dim i As Long, j As Long, r As Long, MyData As Variant, str1 As String
Dim MyMax As Long, Results As Object, NumItems As Long, NumSet As Long
    
    NumItems = 20
    NumSet = 10
    
    ReDim z(1 To NumItems)
    ReDim ix(1 To NumItems)
    
    Set MyDict = CreateObject("Scripting.Dictionary")
    Set Results = CreateObject("Scripting.Dictionary")
    MyData = Sheets("Sheet8").Range("A1").Resize(Sheets("Sheet8").Cells(Rows.Count, "A").End(xlUp).Row, NumItems).Value
    MyMax = -1
    ctr = 0
    
    For r = 1 To UBound(MyData)
        For i = 1 To NumItems
            z(i) = MyData(r, i)
        Next i
        Call QuickSort(z, 1, NumItems)
        For i = 0 To 2 ^ NumItems - 1
            If ctr = NumSet Then
                str1 = ""
                For j = 1 To NumItems
                    If ix(j) = 1 Then str1 = str1 & z(j) & "."
                Next j
                MyDict(str1) = MyDict(str1) + 1
                If MyDict(str1) > MyMax Then
                    MyMax = MyDict(str1)
                    Results.RemoveAll
                End If
                If MyDict(str1) = MyMax Then Results(str1) = 1
            End If
            
            For j = 1 To NumItems
                ix(j) = ix(j) + 1
                If ix(j) = 1 Then ctr = ctr + 1
                If ix(j) = 1 Then Exit For
                ix(j) = 0
                ctr = ctr - 1
            Next j
        Next i
        
    Next r


    Sheets("Sheet9").Range("A1") = MyMax
    Sheets("Sheet9").Range("B1").Resize(Results.Count) = WorksheetFunction.Transpose(Results.keys)
    
End Sub


Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)


  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long


  tmpLow = inLow
  tmpHi = inHi


  pivot = vArray((inLow + inHi) \ 2)


  While (tmpLow <= tmpHi)


     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend


     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend


     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If


  Wend


  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi


End Sub
 
Upvote 0
MickG said:
So to recap:-
Would it be right to say you want, the/Any ten numbers from any single row, that repeat themselves the maximum number of times in any of the other rows.

If so, do they need to be (not in the same relative cells), but in the same order ???
so in your example above would it be acceptable to have the first and second line as below:-
1348911____
29741012____

<tbody>
</tbody>
Click to expand...

First question: Yes. I want to find if any ten numbers from any single row are repeated in any of the other rows, and if so, how many times/rows.​

Second question: They do not need to be in the same order. They can be in any order, but they can also be sorted in ascending order before I run the code.
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Combining named worksheets with Macro
Replies
4
Views
491
Exl_in_Training
E
J
  • Question
Macro for copying data from multiple sheets to a common sheet based on a cell value
Replies
0
Views
207
jmk15315
J
C
  • Question
Running Data Refresh Macro, then Table Update Macro, Back-to-Back?
2
Replies
11
Views
526
Alex Blakenburg
A
J
  • Question
Nested Information
Replies
5
Views
360
jomiscli
J
S
  • Question
Extracting text within varying length phrases
Replies
8
Views
869
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,214,652
Messages
6,120,747
Members
448,989
Latest member
mariah3

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