Help!! find two number recurring numbers in row??

[carrolld2]

Hi everyone, new to posting on this forum so thank you for your patience.


I have a spreadsheet which has data in 7 columns and around 100 rows. I want to be able to find what two numbers appear most frequent together on each of the rows. They don’t have to appear side by side they can appear anywhere on the row. It is kind of like the mode but instead of finding which number is most frequent it is to find what two numbers appear most frequent on each row? To give a better idea of what i mean I have inserted some sample data below. The red highlighted numbers of 26 & 29 appear 5 times on separate rows so I would want Excel to indicate that 26 & 29 are the most frequent on each row? The numbers can only appear once on a row and the range is between 1-50...
Sorry if the explanation is not clear it’s hard to put in words.
I have searched all around but can find a solution, any help from you excel gods would be much appreciated.

Thank you.....

[macropod]

Hi carrolld2,

Try the following macro. As coded, it will handle cells with values up to 999.

Sub MaxMatch()
Dim LRow As Long, LCol As Long, StrData As String, bFnd As Boolean
Dim C As Long, R As Long, I As Long, J As Long, ArrPairs() ' Array
ReDim Preserve ArrPairs(1, 0)
With ActiveSheet
  LRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
  LCol = .Cells.SpecialCells(xlCellTypeLastCell).Column - 1
  For C = 1 To LCol
    For R = 1 To LRow
      StrData = Format(.Cells(R, C).Value, "000") & Format(.Cells(R, C + 1).Value, "000")
      bFnd = False
      For I = 0 To UBound(ArrPairs, 2) - 1
        If StrData = ArrPairs(0, I) Then
          bFnd = True
          ArrPairs(1, I) = ArrPairs(1, I) + 1
          Exit For
        End If
      Next
      I = I + 1
      If bFnd = False Then
        ReDim Preserve ArrPairs(1, I)
        ArrPairs(0, I) = StrData
        ArrPairs(1, I) = 1
      End If
    Next
  Next
  For I = 0 To UBound(ArrPairs, 2) - 1
    If ArrPairs(1, I) > ArrPairs(1, J) Then
      J = I
    End If
  Next
  MsgBox "The greatest paired match frequency is for" & vbCr & _
    Int(ArrPairs(0, J) / 1000) & " & " & ArrPairs(0, J) Mod 1000 & _
    ", with " & ArrPairs(1, J) & " matches."
End With
End Sub

Note: if your active range extends beyond the used range, you'll end up evaluating empty cells, quite likely leading to them accounting for the most frequent matches.

[carrolld2]

Hi macropod,
That seems to be exactally what I needed, however as you stated it is returning values of 0&0. Is there a way for me to specify a range of cells for it to search, or mark the cells with numbers as active cells?

Thanks for the help!!!

carrolld2

[macropod]

Hi carrolld2,

The simplest approach is to press Ctrl-End, which takes you to the last active cell, then delete all unused columns and rows and re-save the workbook. Do this correctly, and pressing Ctrl-End will take you to the last used cell. The macro should then 'work as advertised'.

If that doesn't suit your needs, you could change:
LRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
LCol = .Cells.SpecialCells(xlCellTypeLastCell).Column - 1
to:
StrData = InputBox("Please input the last cell address")
LRow = .Range(StrData).Row
LCol = .Range(StrData).Column - 1

[kconner]

Is it possible for you to tweak the code to give the top 3 reoccurring numbers in order like 1st, 2nd, and 3rd place. I would also like it to not only show the 2 most reoccurring numbers but 3 most,4,5, and 6

[whatsup]

Hi

Another approach:

 
 Sub Get_List()
Dim arrData As Variant
Dim arrSearch As Variant
Dim arrSort As Variant
Dim strSearch As String
Dim objdic As Object
Dim lngR As Long, lngC As Long, lngN As Long, lngS As Long
Dim lngOutput As Long
  
 lngOutput = 3 '<--Output up to the 3rd best
  
 'Get raw data
With ActiveSheet
    arrData = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
End With
  
 arrSearch = InputBox("How many columns shall be joined to look for?" & vbCrLf _
                    & "The limit is: " & UBound(arrData, 2), "Create Search-String", "2")
 
If Not IsNumeric(arrSearch) Then GoTo TheEnd
If CLng(arrSearch) > UBound(arrData, 2) Then GoTo TheEnd
If CLng(arrSearch) > 0 Then
    lngN = CLng(arrSearch) - 1
Else
    GoTo TheEnd
End If
  
 Set objdic = CreateObject("scripting.dictionary")
 
'Search and count pairs
For lngR = 1 To UBound(arrData, 1)
    For lngC = 1 To UBound(arrData, 2) - lngN
        strSearch = ""
        For lngS = 0 To lngN
            strSearch = strSearch & arrData(lngR, lngC + lngS) & ";"
        Next lngS
        If objdic.exists(strSearch) Then
            objdic(strSearch) = objdic(strSearch) + 1
        Else
            objdic(strSearch) = 1
        End If
    Next lngC
Next lngR
'No results:
If objdic.Count = 0 Then
    MsgBox "No results!"
    Set objdic = Nothing
    Exit Sub
End If
'Sorting results:
If objdic.Count > 1 Then
    'Get keys and items for sorting
    arrSearch = objdic.Keys
    arrSort = objdic.Items
    'Sort the list
        QuickSort arrSort, arrSearch
    'Get number of Data matching best of (up to lngOutput)
    lngS = 1
    For lngR = 1 To UBound(arrSort)
        If arrSort(lngR) < arrSort(lngR - 1) Then
            lngS = lngS + 1
            If lngS > lngOutput Then
                lngOutput = lngR - 1
                Exit For
            End If
        End If
    Next lngR
    If lngR > UBound(arrSort) Then
        'If lngS = 1 Then
            lngOutput = UBound(arrSort)
        'End If
    End If
End If
'Shuffle results back to an array
If lngOutput > UBound(arrSort) Then
    lngOutput = UBound(arrSort)
End If
ReDim arrData(0 To lngOutput, 0 To 1)
For lngR = 0 To lngOutput
    arrData(lngR, 0) = arrSearch(lngR)
    arrData(lngR, 1) = arrSort(lngR)
Next lngR
'Output
With Sheets("Output")
    .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
    .Cells(1, 1).Resize(UBound(arrData, 1) + 1, 2).Value = arrData
    .Activate
End With
 Set objdic = Nothing
Exit Sub
 TheEnd:
    MsgBox "InputBox wasn't filled correctly!"
    
End Sub
  
 Private Sub QuickSort(vSort As Variant, vData As Variant, _
                        Optional ByVal lngStart As Variant, _
                        Optional ByVal lngEnd As Variant)
If IsMissing(lngStart) Then lngStart = LBound(vSort)
If IsMissing(lngEnd) Then lngEnd = UBound(vSort)
Dim i As Long
Dim j As Long
Dim h As Variant
Dim x As Double
i = lngStart: j = lngEnd
x = vSort((lngStart + lngEnd) / 2)
Do
    While (vSort(i) > x): i = i + 1: Wend
    While (vSort(j) < x): j = j - 1: Wend
    If (i <= j) Then
        h = vSort(i)
        vSort(i) = vSort(j)
        vSort(j) = h
        h = vData(i)
        vData(i) = vData(j)
        vData(j) = h
        i = i + 1: j = j - 1
    End If
Loop Until (i > j)
If (lngStart < j) Then QuickSort vSort, vData, lngStart, j
If (i < lngEnd) Then QuickSort vSort, vData, i, lngEnd
End Sub

You will need a Sheet within your workbook named "Output".
Activate the sheet where your data is in and start the macro.
The code is based on the example from the threadstarter. The result will be a sorted (desc.) list, showing the combinations up to the 3rd best including their number of occurrence. You may change the value of the variable "lngOutput" to your convenience.

Be aware:
If your raw datafield is exceeding an equivalent of 6105 x 6105 (Rows x Columns) an error might come up because of insufficient memory. If number of results are exceeding available rows in your sheet you also will face an error.