Good evening,
I have the code below that works when the data starts in cell “B3” in the “Input” sheet and goes down to cell “G whatever”. The last row changes on a regular basis but the columns will always be “B:G”.
Here is the code ...
[VBA]Option Explicit
Sub Quadruples()
Dim rng As Range ' The entire range of ALL Lotto numbers drawn to date
Dim wsResult As Worksheet ' The sheet where ALL the calculated ouput resides
Dim lRow As Long ' Row in the [Results] sheet to start output from (NOT titles)
Dim c As Range ' Loop through the individual cells in the data range [rng]
Dim i As Integer ' Offset of 1 column in the [Input] sheet (column B)
Dim j As Integer ' Offset of 2 columns in the [Input] sheet (column C)
Dim k As Integer ' Offset of 3 columns in the [Input] sheet (column D)
Dim l As Integer ' Offset of 4 columns in the [Input] sheet (column E)
Dim m As Integer ' Offset of 5 columns in the [Input] sheet (column F)
Dim iSingle As Integer ' Combinations of 1 number
Dim strDouble As String ' Combinations of 2 numbers
Dim strTriplet As String ' Combinations of 3 numbers
Dim strQuadruple As String ' Combinations of 4 numbers
Dim strQuintuple As String ' Combinations of 5 numbers
Dim strSextuple As String ' Combinations of 6 numbers
Dim lRow2 As Long ' Total occurances output to the [Results] sheet ?
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Worksheets("Input").Select
' Store a reference to the [UsedRange] in the [Input] sheet
Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("B8:G" & ActiveSheet.Rows.Count))
' If there are NO draws in the [Input] sheet then [Exit Sub]
If rng Is Nothing Then
MsgBox "There is NO Draw Information to Process", vbInformation, "Warning"
Range("B3").Select
Exit Sub
End If
If Not rng Is Nothing Then
' Add [Results] sheet OR delete [UsedRange] if it already exists
On Error Resume Next
Set wsResult = ActiveWorkbook.Worksheets("Results")
If wsResult Is Nothing Then
Set wsResult = ActiveWorkbook.Worksheets.Add(After:=Worksheets("Input"))
' Format the WHOLE [Results] sheet as Tahoma
Cells.Font.Name = "Tahoma"
wsResult.Name = "Results"
Else
wsResult.UsedRange.Delete
End If
' Setup column titles (labels) in the [Results] sheet
With wsResult
' Quadruples
.Range("M2").Value = "String"
.Range("N2").Value = "n1"
.Range("N2").Font.Bold = True
.Range("O2").Value = "n2"
.Range("O2").Font.Bold = True
.Range("P2").Value = "n3"
.Range("P2").Font.Bold = True
.Range("Q2").Value = "n4"
.Range("Q2").Font.Bold = True
.Range("R2").Value = "Drawn"
.Range("R2").Font.Bold = True
End With
On Error GoTo 0
' Calculate and output ALL drawn Quadruples and the total times drawn
lRow = 3
For Each c In rng
For i = 1 To 7 - c.Column
For j = 1 To 7 - c.Offset(0, i).Column
For k = 1 To 7 - c.Offset(0, i + j).Column
strQuadruple = c.Value & "_" & _
c.Offset(0, i).Value & "_" & _
c.Offset(0, i + j).Value & "_" & _
c.Offset(0, i + j + k).Value
On Error Resume Next
lRow2 = Application.WorksheetFunction.Match(strQuadruple, wsResult.Range("M:M"), False)
If Err.Number > 0 Then
wsResult.Range("M" & lRow).Value = strQuadruple
wsResult.Range("N" & lRow).Value = c.Value
wsResult.Range("N" & lRow).NumberFormat = ("00")
wsResult.Range("O" & lRow).Value = c.Offset(0, i).Value
wsResult.Range("O" & lRow).NumberFormat = ("00")
wsResult.Range("P" & lRow).Value = c.Offset(0, i + j).Value
wsResult.Range("P" & lRow).NumberFormat = ("00")
wsResult.Range("Q" & lRow).Value = c.Offset(0, i + j + k).Value
wsResult.Range("Q" & lRow).NumberFormat = ("00")
wsResult.Range("R" & lRow).Value = 1
lRow = lRow + 1
Else
wsResult.Range("R" & lRow2).Value = wsResult.Range("R" & lRow2).Value + 1
End If
On Error GoTo 0
Next k
Next j
Next i
Next c
End If
Worksheets("Results").Select
With wsResult
.Columns("M").Clear
' Quadruples
Range("N2:R2").End(xlDown).Sort _
Key1:=Range("R2"), Order1:=xlDescending, Header:=xlYes, _
Key2:=Range("N2"), Order2:=xlAscending, Header:=xlYes, _
Key3:=Range("O2"), Order3:=xlAscending, Header:=xlYes
End With
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub[/VBA] ... but when I move the data to start in cell "E8" and go down to cell "J whatever" I can't seem to get it to work
I don't know if it is the "Set rng" bit or setting the initial value of "c".
Thanks in advance.
PAB
Reply With Quote
