Solved: Calculate Distribution

[PAB]

Good afternoon,

I am trying to calculate the number of combinations for set distributions.
I want the code to cycle through the MinBall to MaxBall and count the combintions that have the distributions as set in the code.
I am trying to use Select Case to do this but can't seem to get it to work.
I am probably approaching this completely wrong!


Option Explicit
Option Base 1
Const MinDist As Integer = 1
Const MaxDist As Integer = 6
Const MinBall As Integer = 1
Const MaxBall As Integer = 24
Const TotalComb As Long = 134596
Sub Distribution_3()
Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer
Dim i As Integer
Dim j As Integer
Dim Dist As Double
Dim DistSum(7) As Double
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
With Sheets("Distribution").Select
With ActiveSheet
Cells.Select
Selection.Delete Shift:=xlUp
Selection.ColumnWidth = 3
Range("B2").Select
End With
' Reset to ZERO
For i = MinDist To MaxDist
DistSum(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
Select Case A
Case 1, 2, 3, 4, 5
Dist = 10000
End Select
Select Case B
Case 6, 7, 8, 9, 10
Dist = Dist + 1000
End Select
Select Case C
Case 11, 12, 13, 14, 15
Dist = Dist + 100
End Select
Select Case D
Case 16, 17, 18, 19, 20
Dist = Dist + 10
End Select
Select Case E
Case 21, 22, 23, 24
Dist = Dist + 1
End Select
If Dist = 51 Then DistSum(1) = DistSum(1) + 1
If Dist = 411 Then DistSum(2) = DistSum(2) + 1
If Dist = 42 Then DistSum(3) = DistSum(3) + 1
If Dist = 33 Then DistSum(4) = DistSum(4) + 1
If Dist = 321 Then DistSum(5) = DistSum(5) + 1
If Dist = 222 Then DistSum(6) = DistSum(6) + 1
' Reset [Dist] to ZERO after a Combination (A B C D E F) has been Processed
Dist = 0
Next F
Next E
Next D
Next C
Next B
Next A
With ActiveCell
For i = MinDist To MaxDist
' Calculate Output
.Offset(i + 1, 1).Value = DistSum(i)
.Offset(i + 1, 2).Value = 100 / TotalComb * DistSum(i)
.Offset(i + 1, 3).Value = TotalComb / DistSum(i)
Next i
' Setup Totals
.Offset(i + 2, 1).FormulaR1C1 = "=Sum(R4C3:R[-1]C)"
.Offset(i + 2, 1).Formula = .Offset(i + 2, 1).Value
.Offset(i + 2, 2).FormulaR1C1 = "=Sum(R4C4:R[-1]C)"
.Offset(i + 2, 2).Formula = .Offset(i + 2, 2).Value
End With
End With
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub

Any help will be appreciated.
Thanks in advance.
PAB

[PAB]

I actually left out some distributions in the previous post, they should be:

21111
22110
22200
31110
32100
33000
41100
42000
51000

What I want to do is to calculate the total combinations for each distribution.

So, if we take 22200 for example, that means I want a count of all the combinations that have say 2 numbers from one case, 2 numbers from another case and 2 numbers from another case ONLY.

So, if we take 311100 for example, that means I want a count of all the combinations that have say 3 numbers from one case, 1 number from another case and 1 number from another case and 1 number from another case ONLY.

I have tried a different approach as far as the Case statements but I am still no closer to a resolution.


Option Explicit
Option Base 1
Const MinDist As Integer = 1
Const MaxDist As Integer = 6
Const MinBall As Integer = 1
Const MaxBall As Integer = 24
Const TotalComb As Long = 134596
Sub Distribution_3()
Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer
Dim i As Integer
Dim j As Integer
Dim Dist As Double
Dim DistSum(7) As Double
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
With Sheets("Distribution").Select
With ActiveSheet
Cells.Select
Selection.Delete Shift:=xlUp
Selection.ColumnWidth = 3
Range("B2").Select
End With
' Reset to ZERO
For i = MinDist To MaxDist
DistSum(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
Select Case Dist
Case Dist >= 1 And Dist <= 5
Dist = 10000
Case Dist >= 6 And Dist <= 10
Dist = Dist + 1000
Case Dist >= 11 And Dist <= 15
Dist = Dist + 100
Case Dist >= 16 And Dist <= 20
Dist = Dist + 10
Case Dist >= 21 And Dist <= 24
Dist = Dist + 1
End Select
If Dist = 51 Then DistSum(1) = DistSum(1) + 1
If Dist = 411 Then DistSum(2) = DistSum(2) + 1
If Dist = 42 Then DistSum(3) = DistSum(3) + 1
If Dist = 33 Then DistSum(4) = DistSum(4) + 1
If Dist = 321 Then DistSum(5) = DistSum(5) + 1
If Dist = 222 Then DistSum(6) = DistSum(6) + 1
' Reset [Dist] to ZERO after a Combination (A B C D E F) has been Processed
Dist = 0
Next F
Next E
Next D
Next C
Next B
Next A
With ActiveCell
For i = MinDist To MaxDist
' Calculate Output
.Offset(i + 1, 1).Value = DistSum(i)
.Offset(i + 1, 2).Value = 100 / TotalComb * DistSum(i)
' .Offset(i + 1, 3).Value = TotalComb / DistSum(i)
Next i
' Setup Totals
.Offset(i + 2, 1).FormulaR1C1 = "=Sum(R4C3:R[-1]C)"
' .Offset(i + 2, 1).Formula = .Offset(i + 2, 1).Value
.Offset(i + 2, 2).FormulaR1C1 = "=Sum(R4C4:R[-1]C)"
' .Offset(i + 2, 2).Formula = .Offset(i + 2, 2).Value
End With
End With
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
Any help will be appreciated.
Thanks in advance.

Regards,
PAB

[snb]

To start with:

Instead of


With Sheets("Distribution").Select
With ActiveSheet
Cells.Select
Selection.Delete Shift:=xlUp
Selection.ColumnWidth = 3
Range("B2").Select
End With
end with

use


with Sheets("Distribution").columns
.delete
.columnwidth=3
end with


but I suppose

Sheets("Distribution").cells.clearcontents

suffices

[PAB]

Thanks for the reply snb,

I have been thinking about this.
I had some code that workded out Last Digit distribution.
I have tried to adapt it so as to get the distributions I am after in my previous post but without any success.
It keeps a total and then outputs the total combinations for each distribution.

The structure to be incorporated (probably without the Dist = ?????) is:


Select Case Dist
Case Dist >= 1 And Dist <= 5
Dist = 10000
Case Dist >= 6 And Dist <= 10
Dist = Dist + 1000
Case Dist >= 11 And Dist <= 15
Dist = Dist + 100
Case Dist >= 16 And Dist <= 20
Dist = Dist + 10
Case Dist >= 21 And Dist <= 24
Dist = Dist + 1
End Select
Here is the code:


Option Explicit
Option Base 1
Private HalfDecade(6) As Long
Private Counts(10) As Long
Private Map(10) As Long
Sub Half_Decade()
' I want this to add all the distributions of numbers and the output them
' in the required distributions.
Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer ' Ball Number
Dim n As Long
Dim Total As Long
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With

Map(1) = 21111
Map(2) = 22110
Map(3) = 22200
Map(4) = 31110
Map(5) = 32100
Map(6) = 33000
Map(7) = 41100
Map(8) = 42000
Map(9) = 42000
Map(10) = 51000

For n = 1 To 10
Counts(n) = 0
Next n
For A = 1 To 44
' HalfDecade(1) = 1 + Int(A \ 10 + (A Mod 10) - 1) Mod 9
For B = A + 1 To 45
' HalfDecade(2) = 1 + Int(B \ 10 + (B Mod 10) - 1) Mod 9
For C = B + 1 To 46
' HalfDecade(3) = 1 + Int(C \ 10 + (C Mod 10) - 1) Mod 9
For D = C + 1 To 47
' HalfDecade(4) = 1 + Int(D \ 10 + (D Mod 10) - 1) Mod 9
For E = D + 1 To 48
' HalfDecade(5) = 1 + Int(E \ 10 + (E Mod 10) - 1) Mod 9
For F = E + 1 To 49
' HalfDecade(6) = 1 + Int(F \ 10 + (F Mod 10) - 1) Mod 9
UpdateCounts
Next F
Next E
Next D
Next C
Next B
Next A
Range("A1").Select
For n = 1 To 10
Total = Total + Counts(n)
ActiveCell.Offset(0, 0).Value = Map(n)
ActiveCell.Offset(0, 1).Value = Format(Counts(n), "#,0")
ActiveCell.Offset(1, 1).Value = Format(Total, "#,0")
ActiveCell.Offset(1, 0).Select
Next n
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
Private Sub UpdateCounts()
Dim Cnt(0 To 10) As Long
Dim n As Long
Dim j As Long
Dim max As Long
Dim pattern As Long
For n = 1 To 6
Cnt(HalfDecade(n)) = Cnt(HalfDecade(n)) + 1
Next n
For n = 1 To 6
max = 0
For j = 0 To 4
If Cnt(j) > Cnt(max) Then
max = j
End If
Next j
pattern = pattern * 10 + Cnt(max)
Cnt(max) = 0
Next n
For n = 1 To UBound(Map)
If Map(n) = pattern Then
Counts(n) = Counts(n) + 1
Exit For
End If
Thanks in advance.
PAB

[snb]

You probably mean:


dist = IIf(dist > 5, dist, 0) & 10 ^ (4 - ((dist - 1) \ 5))



instead of that 'select case' code.

[PAB]

Thanks for the reply snb,

I am unsure of how to incorporate that code into my previous post because there is actually a total of FIVE criteria that needs to be recognised.
Thanks again.

Regards,
PAB

[PAB]

I think I am being thick, because I can't seem to get this to work.
Any help will be appreciated.

Kind regards,
PAB

[PAB]

Well, I have tried Select Case and incorporating the criteria underneath the For A ... For F but with no joy.
Below is the latest version of the code which I think will work when the criteria is added.
Any help will be greatly appreciated.

Option Explicit
Option Base 1
Private HalfDecade(6) As Long
Private Counts(10) As Long
Private Map(10) As Long
Sub Half_Decade()
' I want this to add all the distributions of numbers and the output them
' in the required distributions.
Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer ' Ball Number
Dim n As Long
Dim Total As Long
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With

Map(1) = 21111
Map(2) = 22110
Map(3) = 22200
Map(4) = 31110
Map(5) = 32100
Map(6) = 33000
Map(7) = 41100
Map(8) = 42000
Map(9) = 42000
Map(10) = 51000

For n = 1 To 10
Counts(n) = 0
Next n
For A = 1 To 19
For B = A + 1 To 20
For C = B + 1 To 21
For D = C + 1 To 22
For E = D + 1 To 23
For F = E + 1 To 24
'Code to calculate HalfDecade(n)...
' >= 1 And <= 5
' >= 6 And <= 10
' >= 11 And <= 15
' >= 16 And <= 20
' >= 21 And <= 24
'... for A, B, C, D, E & F
UpdateCounts
Next F
Next E
Next D
Next C
Next B
Next A
Range("A1").Select
For n = 1 To 10
Total = Total + Counts(n)
ActiveCell.Offset(0, 0).Value = Map(n)
ActiveCell.Offset(0, 1).Value = Format(Counts(n), "#,0")
ActiveCell.Offset(1, 1).Value = Format(Total, "#,0")
ActiveCell.Offset(1, 0).Select
Next n
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
Private Sub UpdateCounts()
Dim Cnt(0 To 10) As Long
Dim n As Long
Dim j As Long
Dim max As Long
Dim pattern As Long
For n = 1 To 6
Cnt(HalfDecade(n)) = Cnt(HalfDecade(n)) + 1
Next n
For n = 1 To 6
max = 0
For j = 0 To 4
If Cnt(j) > Cnt(max) Then
max = j
End If
Next j
pattern = pattern * 10 + Cnt(max)
Cnt(max) = 0
Next n
For n = 1 To UBound(Map)
If Map(n) = pattern Then
Counts(n) = Counts(n) + 1
Exit For
End If
Next n
End Sub
Thanks in advance.

Kind regards,
PAB

[PAB]

Hi everyone,

I can't seem to figure this out so I think what I will do tomorrow is mark this thread as solved and maybe try to get an answer somewhere else.
Thanks to everyone who looked and helped.

Kind regards,
PAB