Good evening,
I have some code that as standard works correctly.
I have incorporated some additional code which I have tried to adapt to give me some extra information at the bottom of the code that is working.
The code I incorporated used the “ActiveCell.Offset” method and several “Set rng” methods which I have tried to adapt into the “Cells(RowCount & Offset” method with quite good results.
I have spent a lot of time on this trying to get it right and I am almost there but not quite.
What I would like it to do is put the total combinations for each of the “Group Range” in column “C” and then have a grand total of them after the last one.
I have posted the code below ( the added bits are in between stars ) and attached a file.
[vba]Option Explicit
Option Base 1
Const MinBall As Integer = 1 ' The Minimum Value in ANY Combination
Const MaxBall As Integer = 49 ' The Maximum Value in ANY Combination
Const TotalComb As Long = 13983816 ' The Total Number of Combinations in a 649 Lotto
Sub Number_System()
Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer ' Ball Number
Dim i As Integer
Dim nType(23 To 324) As Long
Dim nTypeTotal As Long
Dim Total As Long
Dim RowCount As Integer ' The Array that holds the total number of output rows
' *************************************************************************** ************
' This is EXTRA below
' *************************************************************************** ************
Dim GroupSize As Long
Dim j As Long ' Minimum Group Value.
Dim k As Long ' The Number of Groups to be Used ( Rounded Up if Not Exact ).
Dim l As Long ' Maximum Group Value.
Dim rng1 As Range ' Total Combinations for rng3.
Dim rng2 As Range ' Total Combinations for the First Sum Total in nType.
Dim rng3 As Range ' Total Combinations for the Last Sum Total in nType.
Dim rng4 As Range ' Combinations from the First Sum Total to the Last Sum Total.
Dim rng5 As Range ' Total Combinations for the First Group.
Dim rng6 As Range ' Total Combinations for the Last Group.
Dim rng7 As Range ' Combinations from the First Group to the Last Group.
Dim s As Long ' Combination Structure ( A + B + B + C + D + E + F ).
' *************************************************************************** ************
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
With Sheets("Number System").Select
Cells.Select
Selection.Delete Shift:=xlUp
Selection.ColumnWidth = 3
Range("B2").Select
' Do once here
' *************************************************************************** ************
GroupSize = 20 ' This is EXTRA
' *************************************************************************** ************
For i = LBound(nType) To UBound(nType)
nType(i) = 0
Next i
For A = MinBall To MaxBall - 5
For B = A + 1 To MaxBall - 4
For C = B + 1 To MaxBall - 3
For D = C + 1 To MaxBall - 2
For E = D + 1 To MaxBall - 1
For F = E + 1 To MaxBall
s = A + B + B + C + D + E + F
nType(s) = nType(s) + 1
Next F
Next E
Next D
Next C
Next B
Next A
RowCount = 4
' Display Solution:
' *************************************************************************** ************
Set rng2 = Cells(RowCount + 2, "C") ' This is EXTRA
' *************************************************************************** ************
For i = LBound(nType) To UBound(nType)
Total = Total + i
Cells(RowCount, "B").Value = "A + B + B + C + D + E + F = " & Format(i, "000")
Cells(RowCount, "C").Value = nType(i)
If nType(i) = 0 Then
Cells(RowCount, "D").Value = 0
Else
Cells(RowCount, "D").Value = 100 / TotalComb * nType(i)
End If
If nType(i) = 0 Then
Cells(RowCount, "E").Value = 0
Else
Cells(RowCount, "E").Value = TotalComb / nType(i)
End If
Cells(RowCount, "F").Value = "Draws"
' Format Output
Cells(RowCount, "B").HorizontalAlignment = xlLeft
Cells(RowCount, "B").Resize(1, 5).Borders.LineStyle = xlContinuous
Cells(RowCount, "C").NumberFormat = "##,###,##0"
Cells(RowCount, "D").NumberFormat = "##0.0000000000"
Cells(RowCount, "E").NumberFormat = "##,###,##0.00"
Cells(RowCount, "F").HorizontalAlignment = xlRight
RowCount = RowCount + 1
Next i
' *************************************************************************** ************
Set rng3 = Cells(RowCount + 0, "C") ' This is EXTRA
' *************************************************************************** ************
' Setup Totals
Cells(RowCount, "B").Value = "Totals"
Cells(RowCount, "C").Formula = _
"=Sum(C4:C" & (RowCount - 1) & ")"
Cells(RowCount, "C").Formula = Cells(RowCount, "C").Value
Cells(RowCount, "D").Formula = _
"=Sum(D4" & (RowCount - 1) & ")"
Cells(RowCount, "D").Formula = Cells(RowCount, "D").Value
' Format Totals
Cells(RowCount, "B").Resize(1, 3).Borders.LineStyle = xlContinuous
Cells(RowCount, "B").Resize(1, 3).Interior.ColorIndex = 15
Cells(RowCount, "C").NumberFormat = "#,###,##0"
Cells(RowCount, "D").NumberFormat = "##0.0000000000"
' *************************************************************************** ************
' This is EXTRA below
' *************************************************************************** ************
Set rng4 = Range(rng2, rng3)
k = Application.RoundUp(rng4.Count / GroupSize, 0)
j = LBound(nType)
'Set rng5 = Cells(RowCount + 3, 1)
'Set rng6 = rng1(3 + k, 1)
'Set rng7 = Range(rng5, rng6)
For i = 1 To k
l = j + GroupSize - 1
If l > rng3.Offset(0, -1).Value Then
l = rng3.Offset(0, -1).Value
End If
Cells(RowCount + 3 + i, "B").Value = "A + B + B + C + D + E + F = " & _
Format(j, "000") & " to " & Format(l, "000")
Cells(RowCount + 3 + i, "B").HorizontalAlignment = xlLeft
Cells(RowCount + 3 + i, "C").Value = _
Application.SumIf(rng4.Offset(0, -1), ">=" & j, rng4) - _
Application.SumIf(rng4.Offset(0, -1), ">" & l, rng4)
j = l + 1
Cells(RowCount + 3 + i, "C").NumberFormat = "#,##0"
Cells(RowCount + 3 + i, "C").HorizontalAlignment = xlRight
Next
Cells(RowCount + 3 + i, "B").Value = "Totals"
'rng6.Offset(1, 0).Value = Application.Sum(rng7)
' *************************************************************************** ************
Columns("B:F").Columns.AutoFit
End With
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub[/vba]
Thanks in advance,
PAB
Reply With Quote