How to find the most common pair and triplet numbers?

  • Thread starter Thread starter alessio971
  • Start date Start date
A

alessio971

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
 
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
 
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
Click to expand...

THANK YOU Adriano

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

Thanks again
A
 
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
 
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
 
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
 
I'm not sure I understood what you're wanting to do... Perhaps you'll need to
explain a little further. Are you saying the 6 numbers can be a number from
1 to 49 and you want to list all possible pairs and triplets? By my
calculation, there will be 2,401 pairs and 117,649 triplets... The pairs
won't be much of a problem but the triplets go over 65,000 so it will need to
be split.. but again, maybe I'm not fully understanding the question..


Sub test()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim lCount As Long

lCount = 0
For i = 1 To 49
For j = 1 To 49
lCount = lCount + 1
Next j
Next i
MsgBox lCount & " pairs"

lCount = 0
For i = 1 To 49
For j = 1 To 49
For k = 1 To 49
lCount = lCount + 1
Next k
Next j
Next i

MsgBox lCount & " triplets"

End Sub
 
Hi Vergel Adriano, thanks for the reply.

Please ignore my previous post. I did some calculations and came to
the conclusion that there would be no advantage in listing ALL
combinations of Pairs or Triplets for those that have and haven't
appeared, especially with consideration to the processing time, which
I think would be extreme.
Anyway, I do not have access to Excel for a couple of days so I would
just like to ask a couple of questions please with regard to your
following code. I am new to VBA so please be patient with me.


( 1 ) If ALL the 6 number combinations are in a sheet named "Input"
and in Cells "B3:G?" ( I use "G?" because the row number will
obviously change as more 6 number combinations are entered ), could we
use instead of ...

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

.... something like ...

Set rng = Intersect(Worksheets("Input").Range("B3:G" &
Range("B3").End(xlDown).Row

.... to set the range for ALL 6 number combinations?. Do we also need
to "Select" the "Input" sheet somewhere in the code?.

( 2 ) What if ...

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

.... or ...

Set rng = Intersect(Worksheets("Input").Range("B3:G" &
Range("B3").End(xlDown).Row

.... has no data, could we insert something like ...

If rng Is Nothing Then
Exit Sub

.... or such like?.

( 3 ) Could you please explain what the Dim variables ...

c
lRow
Irow2

.... actaually do please.

( 4 ) What for the Pairs does this actually mean and do please ...

If c.Column <= 5 Then

Thanks VERY much in Advance.
All the Best.
Paul
 
Hi Paul,

(1) No, you won't need to select or activate the Input sheet. You usually
can work with a worksheet or range without selecting it. You can try
something like this:

With Worksheets("Input")
Set rng = .Range("B3:G3").End(xlDown)
End With


(2) Yes, you can validate if rng has no data. But since you're starting
with B3:G3, rng will never be equal to Nothing. What you can do is count
numeric values and if you get anything greater than 0 then it means you have
some data to work with. Something like this:

If Application.WorksheetFunction.Count(rng) > 0 Then
'do something
End If


(3) In the code that I gave, c is a range variable that I used to loop
through the individual cells in the data range, lRow is a Long variable that
I used to keep track of the next available row in the "Results" worksheet and
lRow2 is also a Long variable that I used to determine the row number of a
pair or triplet that already exists in the Results worksheet. If the call to
the Match worksheetfunction does not result in error, then it means lRow2
would have the row number in Results for the current pair or triplet being
tested.

(4) In the code "If c.Column <= 5", 5 means column E. Because in my
example, the data is in columns A to F, then I can only have a pair for
values in columns A to E. If the cell is in column F (i.e., column=6) then,
the code should not do anything. In your case, since you're doing it for
data in columns B to G, you'll want to change the 5 to 6 for pairs and use 5
instead of 4 for triplets.
 
Hi Vergel Adriano,

I have just run your posted code and it is not giving the correct
results for either Pairs or Triplets. I put 2 combinations in a sheet
in Cells "A1:F2" which were :-

1 2 3 4 5 6
1 2 3 4 5 7

The results for "Pairs" should be ...

3 , 6 = 4 Occurances
5 , 6 = 4 Occurances
6 , 7 = 4 Occurances
1 , 5 = 3 Occurances
2 , 5 = 3 Occurances
2 , 6 = 3 Occurances
3 , 5 = 3 Occurances
3 , 7 = 3 Occurances
3 , 8 = 3 Occurances
5 , 7 = 3 Occurances
6 , 8 = 3 Occurances
7 , 8 = 3 Occurances
1 , 2 = 2 Occurances
1 , 3 = 2 Occurances
1 , 6 = 2 Occurances
1 , 7 = 2 Occurances
2 , 3 = 2 Occurances
2 , 7 = 2 Occurances
3 , 4 = 2 Occurances
4 , 6 = 2 Occurances
5 , 8 = 2 Occurances
6 , 9 = 2 Occurances
7 , 9 = 2 Occurances
1 , 4 = 1 Occurances
1 , 8 = 1 Occurances
1 , 9 = 1 Occurances
2 , 4 = 1 Occurances
2 , 8 = 1 Occurances
2 , 9 = 1 Occurances
3 , 9 = 1 Occurances
4 , 5 = 1 Occurances
4 , 7 = 1 Occurances
4 , 8 = 1 Occurances
4 , 9 = 1 Occurances
5 , 9 = 1 Occurances
8 , 9 = 1 Occurances

.... but your code produced ...

V1 V2 Cnt
1 2 2
2 3 2
3 4 2
4 5 2
5 6 1

.... results.
I can't work out why the program is not listing ALL the pairs and the
total occurances.

Thanks for your help.
All the Best.
Paul
 
Paul said:
Sorry to jump in here..
Click to expand...
me too
I have just run your posted code and it is not giving the correct
results for either Pairs or Triplets. I put 2 combinations in a sheet
in Cells "A1:F2" which were :-
1 2 3 4 5 6
1 2 3 4 5 7

The results for "Pairs" should be ...
..
1 , 9 = 1 Occurances
..
Click to expand...

How can 1,9 be a pair occurance when there is no 9?
 
Well spotted Dave D-C,

The actual results for Pairs should be as follows ...

1 , 2 = 2 Occurances
1 , 3 = 2 Occurances
1 , 4 = 2 Occurances
1 , 5 = 2 Occurances
1 , 6 = 1 Occurances
1 , 7 = 1 Occurances
2 , 3 = 2 Occurances
2 , 4 = 2 Occurances
2 , 5 = 2 Occurances
2 , 6 = 1 Occurances
2 , 7 = 1 Occurances
3 , 4 = 2 Occurances
3 , 5 = 2 Occurances
3 , 6 = 1 Occurances
3 , 7 = 1 Occurances
4 , 5 = 2 Occurances
4 , 6 = 1 Occurances
4 , 7 = 1 Occurances
5 , 6 = 1 Occurances
5 , 7 = 1 Occurances
6 , 7 = 0 Occurances

.... NOT as previously stated.
Your code Vergel Adriano produced ...

V1 V2 Cnt
1 2 2
2 3 2
3 4 2
4 5 2
5 6 1

Thanks in Advance.
All the Best.
Paul
 
I think this is what you're looking for.

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
Dim i As Integer
Dim j As Integer

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
For i = 1 To 6 - c.Column
strPair = c.Value & "_" & c.Offset(0, i).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,
i).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
Next i
End If
Next c

'Find Triplets
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

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
 
Thanks Vergel Adriano,

It is almost there.
I ran your code this morning and it does indeed produce only the
combinations that are relevant. The only thing is that it is not
totally properly. It shows a count of 1 for all the combinations where
some should be 2. I think it is calculating the totals purely on the
first combination and then going onto the second combination, but
there are the same combinations in both so the total should be 2.

Thanks again for all your help and time on this, it is very much
appreciated.
All the Best.
Paul
 
Paul,

I used the sample data that you gave and the code produced the same result
that you identified. So, with this data in A1:F2:

1 2 3 4 5 6
1 2 3 4 5 7

can you tell me for which pair the code is giving a count of 1 but should be
2?
 
Hi Vergel Adriano,

It comes up with an ERROR on the line ...

wsResult.Range("D" & lRow2).Value =wsResult.Range("D" & lRow2).Value 1

.... for both Pairs & Triplets, but if you remove the 1 at the end it
appears to be OK.

Your program for combinations ...

1 2 3 4 5 6
1 2 3 4 5 7

.... produces the results ...

1 , 2 = 1
1 , 3 = 1
1 , 4 = 1
1 , 5 = 1
1 , 6 = 1
2 , 3 = 1
2 , 4 = 1
2 , 5 = 1
2 , 6 = 1
3 , 4 = 1
3 , 5 = 1
3 , 6 = 1
4 , 5 = 1
4 , 6 = 1
5 , 6 = 1
1 , 7 = 1
2 , 7 = 1
3 , 7 = 1
4 , 7 = 1
5 , 7 = 1

.... where it should be ...

1 , 2 = 2
1 , 3 = 2
1 , 4 = 2
1 , 5 = 2
1 , 6 = 1
2 , 3 = 2
2 , 4 = 2
2 , 5 = 2
2 , 6 = 1
3 , 4 = 2
3 , 5 = 2
3 , 6 = 1
4 , 5 = 2
4 , 6 = 1
5 , 6 = 1
1 , 7 = 1
2 , 7 = 1
3 , 7 = 1
4 , 7 = 1
5 , 7 = 1

.... because some Pairs are in BOTH combinations. This would obviously
be more if there were more than 2 combinations to evaluate.

Thanks in Advance.
All the Best.
Paul
 
hmmn.. not sure what happened, but I think I see the problem. The line that
you identified is the line where the count is incremented by 1. But somehow
the "+" operator got left out. Those lines should be like this:

For the pairs:

wsResult.Range("D" & lRow2).Value =wsResult.Range("D" & lRow2).Value + 1


For the triplets:

wsResult.Range("I" & lRow2).Value = wsResult.Range("I" & lRow2).Value + 1
 
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
 
Sorry Vergel Adriano,

I tried applying the logic to produce Quadruples but I can't seem to
get it to work.

Thanks in Advance.
All the Best.
Paul
 
Back
Top