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

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

[VBA]
with Sheets("Distribution").columns
.delete
.columnwidth=3
end with
[/VBA]

but I suppose

[VBA]Sheets("Distribution").cells.clearcontents[/VBA]

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:

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

[/VBA]

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.

[vba]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[/vba]
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