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

On Aug 20, 4:14 pm, Paul Black wrote:
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

On Aug 16, 2:51 pm, Paul Black wrote:



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

On Aug 16, 2:16 pm, Paul Black wrote:

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

On Aug 16, 11:09 am, Paul Black wrote:

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

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

--
Hope that helps.

Vergel Adriano

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

On Aug 15, 3:32 pm, Vergel Adriano
wrote:
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?

--
Hope that helps.

Vergel Adriano

"Paul Black" wrote:
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 thetotalshould be 2.

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

On Aug 14, 11:48 pm, Vergel Adriano
wrote:
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

...

read more »- Hide quoted text -

- Show quoted text -