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" wrote:

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
wrote:
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



" wrote:
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- Hide quoted text -

- Show quoted text -