Excel - How to find the most common pair and triplet numbers?

Asked By alessio97 on 11-Aug-07 06:31 PM
Hi

I have been looking into this for few weeks now but I can't find a
solution ...

I have 200 rows of data composed of numbers from 1 to 10 on column A
to F.

I need to find out the most pair / triplet for the all table. Perhaps
the following example will explain better


1_2_3_4_5_6
1_2_5_6_7_9
2_3_5_6_7_8
3_4_6_7_8_9
1_3_5_6_7_8

Most common pair = 6_7
Most common triplet = 5_6_7

Hope this is clear ... thank you in advance

A




VergelAdrian replied on 11-Aug-07 07:28 PM
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



--
Hope that helps.

Vergel Adriano
alessio97 replied on 12-Aug-07 04:31 AM
THANK YOU Adriano

works perfectly ... I want to spend some time reviewing the code to
understand the all process.

Thanks again
A
Paul Black replied on 12-Aug-07 07:49 AM
Hi Vergel Adriano,

Sorry to jump in here A.
Would it be possible to adapt the codes so it outputs ALL the
combinations of Pairs & Triplets with the total amount of times they
have appeared please.
Maybe the results could go in a sheet named "Results" and :-
(1) The Pairs go in Cells "A1" & "B1" going down and the total times
appeared in Cell "C1" going down.
(2) The Triples go in Cells "E1", "F1" & "G1" going down and the total
times appeared in Cell "H1" going down.

Thanks in Advance.
All the Best.
Paul

On Aug 12, 12:28 am, Vergel Adriano
VergelAdrian replied on 12-Aug-07 12:06 PM
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


--
Hope that helps.

Vergel Adriano
Paul Black replied on 12-Aug-07 02:40 PM
Hi Vergel Adriano,

Thanks VERY much for revised code, it is appreciated.
I had an idea after I posted my request.
It would be nice if the code could find the highest number in any of
the 6 number combinations using something like the Max worksheet
function and assigning it to a variable like maxVal for example. Then
we could calculate and list ALL the combinations of Pairs & Triplets
whether they have appeared or not along with the total occurances for
each. Obviously some of them will not have appeared as yet so will
show zero.
I know there are 1,176 Pairs of combinations for 6 from 49 and 18,424
Triplets for 6 from 49.
Would this be easy to do or would it make the processing time to
produce the results very long?.

Thanks in Advance.
All the Best.
Paul

On Aug 12, 5:06 pm, Vergel Adriano
David Hilberg replied on 12-Aug-07 04:11 PM
You could take some of your Lotto winnings and buy an Excel
textbook ;)
Paul Black replied on 16-Aug-07 06:09 AM
Hi Vergel Adriano,

Excellent, it works like a dream.
One final point, honestly, how would I get it to calculate singles
please.
Thanks for ALL your help, time & patience with regard to this, it is
appreciated.

Thanks in Advance.
All the VERY Best.
Paul

On Aug 15, 4:26 pm, Vergel Adriano
Dana DeLouis replied on 16-Aug-07 10:44 AM
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

--
HTH   :>)
Dana DeLouis
Paul Black replied on 27-Aug-07 12:41 PM
Hi Vergel Adriano,

Out of interest was do the variables i & j actually do please.


Thanks in Advance.
All the Best.
Paul