How to find the most common pair and triplet numbers?

[Paul Black]

Hi Vergel Adriano,

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.

Thanks in Advance.
All the Best.
Paul

 

[Dana DeLouis]

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
Dic.Add Key, 1
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

 

[Paul Black]

Hi Vergel Adriano,

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.

Thanks in Advance.
All the Best.
Paul

 

[Paul Black]

Hi Vergel Adriano,

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
Application.DisplayAlerts = False

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
Set wsResult = ActiveWorkbook.Worksheets.Add
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.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Thanks in Advance.
All the Best
Paul

 

[Paul Black]

Hi Vergel Adriano,

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

Thanks in Advance.
All the Best.
Paul

 

[Paul Black]

Hi Vergel Adriano,

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

Thanks in Advance.
All the Best.
Paul

 

[ubatu05]

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
Application.DisplayAlerts = False

If Not rng Is Nothing Then
Set ws = ActiveWorkbook.Worksheets.Add
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.DisplayAlerts = True
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
Application.DisplayAlerts = False

If Not rng Is Nothing Then
Set ws = ActiveWorkbook.Worksheets.Add
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.DisplayAlerts = True
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
Application.DisplayAlerts = 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
Set wsResult = ActiveWorkbook.Worksheets.Add
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


Application.DisplayAlerts = True
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? That is suppose the numbers start from cell A1 to E1?