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