# How to find the most common pair and triplet numbers?

Don't worry about the Quadruples I have worked it out, it is just the
singles I can't figure out how to do.
The ...

If c.Column <= 5 Then
< code here >
End If

.... is now obsolete I found out so I have omitted them.

All the Best.
Paul

Hi. Here's just an idea if interested.
I would do a search of these newsgroups for programs that do "Subsets" (ie
of size 2, 3, etc).
There are all kinds of techniques, so pick one you like.
I would break the problem down into 4 steps
Grab each row of data.
Sort that data (so 1,2 and 2,1 are the same)
Call Subset Program
Dump this data into a totals program.

Here's a general idea if interested.
In the vba editor, set a Tools | Reference to the library below.
One of the many, many terrible things about Excel 2007 is that Microsoft
Help system removed Methods and Properties, so It's almost impossible to
study new ideas.
Therefore, set the library ref to help a little via auto complete.
This is just a quick way to count subsets of size 2 combined.

Option Explicit
Dim Dic As Dictionary

' = = = = =
' Best w/ Ref to "Microsoft Scripting Runtime"
' = = = = =

Sub Demo()
Dim Dic As New Dictionary
Dim M As Variant '(M)atrix
Dim r As Long '(R)ow
Dim j As Long
Dim k As Long
Dim Key As String
Const Comma As String = ","

M = [A1:F2].Value
'or
'M = [A1].CurrentRegion.Value
For r = 1 To UBound(M, 1)
For j = 1 To 5
For k = j + 1 To 6
Key = Join(Array(M(r, j), M(r, k)), Comma)
If Dic.Exists(Key) Then
Dic.Item(Key) = Dic.Item(Key) + 1
Else
End If
Next k, j, r

Range("H1:I1").Resize(Dic.Count) = _
WorksheetFunction.Transpose(Array(Dic.Keys, Dic.Items))

' Sort here if desired
End Sub

Have you had chance to have a look at how I can produce the singles
please. This will finish what I am trying to achieve.

All the Best.
Paul

This is the final thing, honestly.
Why wont this code work, it is set up exactly as the Pairs & Triplets
are :-

Option Explicit

Sub Singles()

Dim rng As Range
Dim wsResult As Worksheet
Dim lRow As Long
Dim c As Range
Dim strSingle As String
Dim lRow2 As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set rng = Intersect(ActiveSheet.UsedRange,
ActiveSheet.Range("A:F"))

If Not rng Is Nothing Then

' Select and Prepare OR Create "Results" Worksheet.
On Error Resume Next
Set wsResult = ActiveWorkbook.Worksheets("Results")
If wsResult Is Nothing Then
wsResult.Name = "Results"
Else
wsResult.UsedRange.Delete
End If

' "Results" Sheet Setup.
With wsResult

' < Singles Setup >
.Range("A1").Value = "String"
.Range("B1").Value = "n1"
.Range("C1").Value = "Drawn"

End With
On Error GoTo 0

' Find, Calculate and Output ALL Drawn Singles and Statistics.
lRow = 2
For Each c In rng
strSingle = c.Value

On Error Resume Next
lRow2 = Application.WorksheetFunction.Match(strSingle,
wsResult.Range("A:A"), False)
If Err.Number > 0 Then
wsResult.Range("A" & lRow).Value = strSingle
wsResult.Range("B" & lRow).Value = c.Value
wsResult.Range("C" & lRow).Value = 1
lRow = lRow + 1
Else
wsResult.Range("C" & lRow2).Value = wsResult.Range("C"
& lRow2).Value + 1
End If
On Error GoTo 0
Next c
End If

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

All the Best
Paul

I have tried everything with my limited knowledge to get this to work
but to NO avail.
Any help will be greatly appreciated.

All the Best.
Paul

Out of interest was do the variables i & j actually do please.
'FindTriplets
lRow = 2
For Each c In rng
If c.Column <= 5 Then
For i = 1 To 6 - c.Column
For j = 1 To 6 - c.Offset(0, i).Column
strTriplet = c.Value & "_" & c.Offset(0, i).Value &
"_" & c.Offset(0, i + j).Value

On Error Resume Next
lRow2 =
Application.WorksheetFunction.Match(strTriplet, wsResult.Range("E:E"), False)
If Err.Number > 0 Then
wsResult.Range("E" & lRow).Value = strTriplet
wsResult.Range("F" & lRow).Value = c.Value
wsResult.Range("G" & lRow).Value = c.Offset(0,
i).Value
wsResult.Range("H" & lRow).Value = c.Offset(0, i
+ j).Value
wsResult.Range("I" & lRow).Value = 1
lRow = lRow + 1
Else
wsResult.Range("I" & lRow2).Value =
wsResult.Range("I" & lRow2).Value + 1
End If
On Error GoTo 0
Next j
Next i
End If
Next c
End If

All the Best.
Paul

maybe something like this:

Sub MostCommonPair()
Dim rng As Range
Dim c As Range
Dim strPair As String
Dim ws As Worksheet
Dim lRow As Long
Dim lRow2 As Long
Dim lCount As Long

Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:F"))

Application.ScreenUpdating = False

If Not rng Is Nothing Then
lRow = 1
For Each c In rng
If c.Column <= 5 Then
strPair = c.Value & "_" & c.Offset(0, 1).Value

On Error Resume Next
lRow2 = Application.WorksheetFunction.Match(strPair,
ws.Range("A:A"), False)
If Err.Number > 0 Then
ws.Range("A" & lRow).Value = strPair
ws.Range("B" & lRow).Value = 1
lRow = lRow + 1
Else
ws.Range("B" & lRow2).Value = ws.Range("B" &
lRow2).Value + 1
End If
On Error GoTo 0
End If
Next c
End If

'get the one with largest count
With Application.WorksheetFunction
lCount = .Large(ws.Range("B:B"), 1)
lRow = .Match(lCount, ws.Range("B:B"), False)
End With
MsgBox "Most Common Pair is " & ws.Range("A" & lRow) & " (" & lCount & "
occurrences)"

ws.Delete

Application.ScreenUpdating = True

End Sub

Sub MostCommonTriplet()
Dim rng As Range
Dim c As Range
Dim strTriplet As String
Dim ws As Worksheet
Dim lRow As Long
Dim lRow2 As Long
Dim lCount As Long

Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:F"))

Application.ScreenUpdating = False

If Not rng Is Nothing Then
lRow = 1
For Each c In rng
If c.Column <= 4 Then
strTriplet = c.Value & "_" & c.Offset(0, 1).Value & "_" &
c.Offset(0, 2).Value

On Error Resume Next
lRow2 = Application.WorksheetFunction.Match(strTriplet,
ws.Range("A:A"), False)
If Err.Number > 0 Then
ws.Range("A" & lRow).Value = strTriplet
ws.Range("B" & lRow).Value = 1
lRow = lRow + 1
Else
ws.Range("B" & lRow2).Value = ws.Range("B" &
lRow2).Value + 1
End If
On Error GoTo 0
End If
Next c
End If

'get the one with largest count
With Application.WorksheetFunction
lCount = .Large(ws.Range("B:B"), 1)
lRow = .Match(lCount, ws.Range("B:B"), False)
End With
MsgBox "Most Common Triplet is " & ws.Range("A" & lRow) & " (" & lCount
& " occurrences)"

ws.Delete

Application.ScreenUpdating = True

End Sub

What about if the columns are 5 with numbers ranging from 1 to 90? what will change in the code above
Hi Paul,

Give this a try.

Sub MostCommonPairAndTriplet()
Dim rng As Range
Dim c As Range
Dim strPair As String
Dim strTriplet As String
Dim wsResult As Worksheet
Dim lRow As Long
Dim lRow2 As Long

Application.ScreenUpdating = False

Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:F"))

If Not rng Is Nothing Then

'Get the result worksheet
On Error Resume Next
Set wsResult = ActiveWorkbook.Worksheets("Results")
If wsResult Is Nothing Then
wsResult.Name = "Results"
Else
wsResult.UsedRange.Delete
End If
'column labels
With wsResult
.Range("B1").Value = "Value1"
.Range("C1").Value = "Value2"
.Range("D1").Value = "Count"
.Range("F1").Value = "Value1"
.Range("G1").Value = "Value2"
.Range("H1").Value = "Value3"
.Range("I1").Value = "Count"
End With
On Error GoTo 0

'Find Pairs
lRow = 2
For Each c In rng
If c.Column <= 5 Then
strPair = c.Value & "_" & c.Offset(0, 1).Value

On Error Resume Next
lRow2 = Application.WorksheetFunction.Match(strPair,
wsResult.Range("A:A"), False)
If Err.Number > 0 Then
wsResult.Range("A" & lRow).Value = strPair
wsResult.Range("B" & lRow).Value = c.Value
wsResult.Range("C" & lRow).Value = c.Offset(0, 1).Value
wsResult.Range("D" & lRow).Value = 1
lRow = lRow + 1
Else
wsResult.Range("D" & lRow2).Value = wsResult.Range("D" &
lRow2).Value + 1
End If
On Error GoTo 0
End If
Next c

'Find Triplets
lRow = 2
For Each c In rng
If c.Column <= 4 Then
strTriplet = c.Value & "_" & c.Offset(0, 1).Value & "_" &
c.Offset(0, 2).Value

On Error Resume Next
lRow2 = Application.WorksheetFunction.Match(strTriplet,
wsResult.Range("E:E"), False)
If Err.Number > 0 Then
wsResult.Range("E" & lRow).Value = strTriplet
wsResult.Range("F" & lRow).Value = c.Value
wsResult.Range("G" & lRow).Value = c.Offset(0, 1).Value
wsResult.Range("H" & lRow).Value = c.Offset(0, 2).Value
wsResult.Range("I" & lRow).Value = 1
lRow = lRow + 1
Else
wsResult.Range("I" & lRow2).Value = wsResult.Range("I" &
lRow2).Value + 1
End If
On Error GoTo 0
End If
Next c
End If

wsResult.Columns("E").Clear
wsResult.Columns("A").Delete

'Sort the pairs
With wsResult
.Columns("A:C").Sort Key1:=.Range("C2"), Order1:=xlDescending
.Columns("E:H").Sort Key1:=.Range("H2"), Order1:=xlDescending
End With