Can this code be optimized with regard to the Do While...Loop?

[PAB]

Good afternoon,

I have lotto dates starting in range D8 and continuing downwards.
I have lotto balls drawn starting in range E8:J and continuing downwards.

The code below cycles down the range E8:J as long as there is a lotto date in column D.
The code produces ALL the triples that have NOT been drawn in any of the draws.
This code works fine but takes a while to run.

My question is please, is there anyway that this code can be optimized with regard to the nx3 part?


Option Explicit
Option Base 1

Const nMax As Integer = 59
Const Criteria As Integer = 0
Const SepChar As String = " "
Dim i As Integer, j As Integer, k As Integer
Dim nx3() As Integer
Dim nNum(6) As Integer
Dim Cel As Range

Sub Triples_VBA_Express()
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With

ReDim nx3(nMax, nMax, nMax)

Set Cel = Range("D8")
Do While Cel.Value <> ""
For j = 1 To 6
nNum(j) = Cel.Offset(0, j).Value
Next j
nx3(nNum(1), nNum(2), nNum(3)) = nx3(nNum(1), nNum(2), nNum(3)) + 1
nx3(nNum(1), nNum(2), nNum(4)) = nx3(nNum(1), nNum(2), nNum(4)) + 1
nx3(nNum(1), nNum(2), nNum(5)) = nx3(nNum(1), nNum(2), nNum(5)) + 1
nx3(nNum(1), nNum(2), nNum(6)) = nx3(nNum(1), nNum(2), nNum(6)) + 1
nx3(nNum(1), nNum(3), nNum(4)) = nx3(nNum(1), nNum(3), nNum(4)) + 1
nx3(nNum(1), nNum(3), nNum(5)) = nx3(nNum(1), nNum(3), nNum(5)) + 1
nx3(nNum(1), nNum(3), nNum(6)) = nx3(nNum(1), nNum(3), nNum(6)) + 1
nx3(nNum(1), nNum(4), nNum(5)) = nx3(nNum(1), nNum(4), nNum(5)) + 1
nx3(nNum(1), nNum(4), nNum(6)) = nx3(nNum(1), nNum(4), nNum(6)) + 1
nx3(nNum(1), nNum(5), nNum(6)) = nx3(nNum(1), nNum(5), nNum(6)) + 1
nx3(nNum(2), nNum(3), nNum(4)) = nx3(nNum(2), nNum(3), nNum(4)) + 1
nx3(nNum(2), nNum(3), nNum(5)) = nx3(nNum(2), nNum(3), nNum(5)) + 1
nx3(nNum(2), nNum(3), nNum(6)) = nx3(nNum(2), nNum(3), nNum(6)) + 1
nx3(nNum(2), nNum(4), nNum(5)) = nx3(nNum(2), nNum(4), nNum(5)) + 1
nx3(nNum(2), nNum(4), nNum(6)) = nx3(nNum(2), nNum(4), nNum(6)) + 1
nx3(nNum(2), nNum(5), nNum(6)) = nx3(nNum(2), nNum(5), nNum(6)) + 1
nx3(nNum(3), nNum(4), nNum(5)) = nx3(nNum(3), nNum(4), nNum(5)) + 1
nx3(nNum(3), nNum(4), nNum(6)) = nx3(nNum(3), nNum(4), nNum(6)) + 1
nx3(nNum(3), nNum(5), nNum(6)) = nx3(nNum(3), nNum(5), nNum(6)) + 1
nx3(nNum(4), nNum(5), nNum(6)) = nx3(nNum(4), nNum(5), nNum(6)) + 1
Set Cel = Cel.Offset(1, 0)
Loop

Set Cel = Range("P7")
For i = 1 To nMax - 2
For j = i + 1 To nMax - 1
For k = j + 1 To nMax
If nx3(i, j, k) = Criteria Then
Set Cel = Cel.Offset(1, 0)
Cel.Offset(0, 0) = _
Format(i, "00") & SepChar & _
Format(j, "00") & SepChar & _
Format(k, "00")
Cel.Offset(0, 1).Value = nx3(i, j, k)
End If
Next k
Next j
Next i

With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub

Thanks in advance.

[p45cal]

try:
Option Explicit
Option Base 1

Const nMax As Long = 59
Const Criteria As Long = 0
Const SepChar As String = " "
Dim i As Long, j As Long, k As Long, z As Long
Dim nx3() As Long
Dim Cel As Range, CelVals, Results()

Sub Triples_VBA_Express4()
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
ReDim Results(Application.WorksheetFunction.Combin(nMax, 3), 1)
ReDim nx3(nMax, nMax, nMax)

Set Cel = Range(Range("D8"), Range("D8").End(xlDown)).Offset(, 1).Resize(, 6)
CelVals = Cel.Value
For i = LBound(CelVals) To UBound(CelVals)
updateme nx3(CelVals(i, 1), CelVals(i, 2), CelVals(i, 3))
updateme nx3(CelVals(i, 1), CelVals(i, 2), CelVals(i, 4))
updateme nx3(CelVals(i, 1), CelVals(i, 2), CelVals(i, 5))
updateme nx3(CelVals(i, 1), CelVals(i, 2), CelVals(i, 6))
updateme nx3(CelVals(i, 1), CelVals(i, 3), CelVals(i, 4))
updateme nx3(CelVals(i, 1), CelVals(i, 3), CelVals(i, 5))
updateme nx3(CelVals(i, 1), CelVals(i, 3), CelVals(i, 6))
updateme nx3(CelVals(i, 1), CelVals(i, 4), CelVals(i, 5))
updateme nx3(CelVals(i, 1), CelVals(i, 4), CelVals(i, 6))
updateme nx3(CelVals(i, 1), CelVals(i, 5), CelVals(i, 6))
updateme nx3(CelVals(i, 2), CelVals(i, 3), CelVals(i, 4))
updateme nx3(CelVals(i, 2), CelVals(i, 3), CelVals(i, 5))
updateme nx3(CelVals(i, 2), CelVals(i, 3), CelVals(i, 6))
updateme nx3(CelVals(i, 2), CelVals(i, 4), CelVals(i, 5))
updateme nx3(CelVals(i, 2), CelVals(i, 4), CelVals(i, 6))
updateme nx3(CelVals(i, 2), CelVals(i, 5), CelVals(i, 6))
updateme nx3(CelVals(i, 3), CelVals(i, 4), CelVals(i, 5))
updateme nx3(CelVals(i, 3), CelVals(i, 4), CelVals(i, 6))
updateme nx3(CelVals(i, 3), CelVals(i, 5), CelVals(i, 6))
updateme nx3(CelVals(i, 4), CelVals(i, 5), CelVals(i, 6))
Next i

''the above is faster than:
''For i = LBound(CelVals) To UBound(CelVals)
'' For j = 1 To 4
'' For k = j + 1 To 5
'' For m = k + 1 To 6
'' updateme nx3(CelVals(i, j), CelVals(i, k), CelVals(i, m))
'' Next m
'' Next k
'' Next j
''Next i

z = LBound(Results) - 1
For i = 1 To nMax - 2
For j = i + 1 To nMax - 1
For k = j + 1 To nMax
DoEvents
If nx3(i, j, k) = Criteria Then
z = z + 1
Results(z, 1) = Format(i, "00") & SepChar & Format(j, "00") & SepChar & Format(k, "00")
End If
Next k
Next j
Next i
Set Cel = Range("P7")
Cel.Resize(z) = Results
Cel.Resize(z).Offset(, 1) = Criteria

With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub

Sub updateme(ByRef a)
a = a + 1
End Sub

[PAB]

Thanks for the reply p45cal,

Unfortunately it falls over on the line...


updateme nx3(CelVals(i, 1), CelVals(i, 2), CelVals(i, 3))

I have tried to work out why but without any success.

Thanks in advance.

[p45cal]

You can either supply a file where this error occurs or supply details of the error message. The former is infinitely preferable.

[p45cal]

Cross posted here: https://www.mrexcel.com/forum/excel-questions/998016-combinations-triples-not-included-range.html#post4791683
S.H.A.D.O./PAB, You've been a member of forums for a number of years now, long enough to be aware of cross posting rules.
Read: http://www.excelguru.ca/content.php?184

You have formulae in column D?

Try replacing the line:
Set Cel = Range(Range("D8"), Range("D8").End(xlDown)).Offset(, 1).Resize(, 6)with:

Set Cel = Range("D8")
Do
z = z + 1
Loop Until Cel.Offset(z).Value = ""
Set Cel = Range(Cel, Cel.Offset(z - 1)).Offset(, 1).Resize(, 6)


ps. you do realise, don't you, because a triple has never been selected in the past, that doesn't increase its chances of being chosen in the future one iota…?

[PAB]

You've been a member of forums for a number of years now, long enough to be aware of cross posting rules.

Sincere appologies for that, it totally slipped my mind.

The revised code works great and is a lot faster.
Thank you for your time and effort, it is appreciated.


You do realise, don't you, because a triple has never been selected in the past, that doesn't increase its chances of being chosen in the future…?

I know, every combination has as much chance as any other combination because the balls have no memory.
The only way to increase your odds of winning is to buy more tickets.

Thanks again, and have a great weekend.