PAB
01-08-2012, 01:31 PM
Good evening,
The code below produces the correct results.
However, I have a small formatting problem.
If I insert a number equal to or higher than 3 in cell “D6” the output is correct by showing the numbers as 01.08.11 for example.
If I insert the number 1 in cell “D6” the output is incorrect because it outputs the numbers as single digits instead of double digits, 1 is shown as 1 and not 01, 8 is shown as 8 and not 08 for example.
If I insert the number 2 in cell “D6” the output is incorrect because it outputs the first number as a single digit instead of double digits, 1 and 8 shows 1.08 instead of 01.08, 8 and 11 shows 8.11 instead of 08.11 for example.
I basically want all the output digits in the format 00 separated with a full stop.
Here is the code ...
Option Explicit
Option Base 1
Sub Combinations_From_Criteria()
Dim Counter1 As Long
Dim Counter2 As Long
Dim CountOff()
Dim Dummy
Dim MaxOff()
Dim myWrap As Long
Dim NewComb As String
Dim NumOfComb As Long
Dim SepChar As String ' Character used between EACH combinations numbers.
Dim SpecificNumbers As Variant
Dim BallsDrawn As Long ' The length of EACH individual combination.
Dim BallsDrawnFrom As Long ' The total number to be drawn from
Dim TotalSpecified As Long
Dim MyDraw As String
Dim i As Long
Dim wsCriteia As Worksheet
Dim wsResults As Worksheet
Set wsCriteia = Worksheets("Criteria")
Set wsResults = Worksheets("Results")
myWrap = 1000 ' Select how many combinations for EACH column.
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
With wsCriteia
BallsDrawn = .Range("D6").Value
BallsDrawnFrom = Range(.Cells(7, 4), .Cells(7, 4).End(xlDown)).Cells.Count
.Activate
.Range("B57").Select
With wsResults
.Cells.ClearContents
SepChar = "."
NumOfComb = Application.Combin(BallsDrawnFrom, BallsDrawn)
ReDim CountOff(BallsDrawn)
ReDim MaxOff(BallsDrawn)
For Counter1 = 1 To BallsDrawn
CountOff(Counter1) = Counter1
MaxOff(Counter1) = BallsDrawnFrom - BallsDrawn + Counter1
Next Counter1
For Counter1 = 1 To NumOfComb
NewComb = ""
For Counter2 = 1 To BallsDrawn
NewComb = NewComb & (CountOff(Counter2)) & SepChar
Next Counter2
MyDraw = ""
'***********************************************************
For i = 1 To BallsDrawn
MyDraw = MyDraw & Format(wsCriteia.Range("D6").Offset _
(Split(NewComb, SepChar)(i - 1)), "00") & SepChar
Next
'***********************************************************
wsResults.Cells(1, 1).Offset(((Counter1 - 1) Mod myWrap), _
Int((Counter1 - 1) / myWrap)) = Left(MyDraw, Len(MyDraw) - Len(SepChar))
CountOff(BallsDrawn) = CountOff(BallsDrawn) + 1
Dummy = BallsDrawn
While Dummy > 1
If CountOff(Dummy) > MaxOff(Dummy) Then
CountOff(Dummy - 1) = CountOff(Dummy - 1) + 1
For Counter2 = Dummy To BallsDrawn
CountOff(Counter2) = CountOff(Counter2 - 1) + 1
Next Counter2
End If
Dummy = Dummy - 1
Wend
Next Counter1
.Cells.EntireColumn.AutoFit
.Cells.EntireColumn.HorizontalAlignment = xlCenter
.Activate
.Range("A1").Select
End With
End With
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
... I think the problem lies within the Asterisks but for the life of me I cannot get it to ouput the results in the correct format.
Thanks in advance.
Kind regards,
PAB
The code below produces the correct results.
However, I have a small formatting problem.
If I insert a number equal to or higher than 3 in cell “D6” the output is correct by showing the numbers as 01.08.11 for example.
If I insert the number 1 in cell “D6” the output is incorrect because it outputs the numbers as single digits instead of double digits, 1 is shown as 1 and not 01, 8 is shown as 8 and not 08 for example.
If I insert the number 2 in cell “D6” the output is incorrect because it outputs the first number as a single digit instead of double digits, 1 and 8 shows 1.08 instead of 01.08, 8 and 11 shows 8.11 instead of 08.11 for example.
I basically want all the output digits in the format 00 separated with a full stop.
Here is the code ...
Option Explicit
Option Base 1
Sub Combinations_From_Criteria()
Dim Counter1 As Long
Dim Counter2 As Long
Dim CountOff()
Dim Dummy
Dim MaxOff()
Dim myWrap As Long
Dim NewComb As String
Dim NumOfComb As Long
Dim SepChar As String ' Character used between EACH combinations numbers.
Dim SpecificNumbers As Variant
Dim BallsDrawn As Long ' The length of EACH individual combination.
Dim BallsDrawnFrom As Long ' The total number to be drawn from
Dim TotalSpecified As Long
Dim MyDraw As String
Dim i As Long
Dim wsCriteia As Worksheet
Dim wsResults As Worksheet
Set wsCriteia = Worksheets("Criteria")
Set wsResults = Worksheets("Results")
myWrap = 1000 ' Select how many combinations for EACH column.
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
With wsCriteia
BallsDrawn = .Range("D6").Value
BallsDrawnFrom = Range(.Cells(7, 4), .Cells(7, 4).End(xlDown)).Cells.Count
.Activate
.Range("B57").Select
With wsResults
.Cells.ClearContents
SepChar = "."
NumOfComb = Application.Combin(BallsDrawnFrom, BallsDrawn)
ReDim CountOff(BallsDrawn)
ReDim MaxOff(BallsDrawn)
For Counter1 = 1 To BallsDrawn
CountOff(Counter1) = Counter1
MaxOff(Counter1) = BallsDrawnFrom - BallsDrawn + Counter1
Next Counter1
For Counter1 = 1 To NumOfComb
NewComb = ""
For Counter2 = 1 To BallsDrawn
NewComb = NewComb & (CountOff(Counter2)) & SepChar
Next Counter2
MyDraw = ""
'***********************************************************
For i = 1 To BallsDrawn
MyDraw = MyDraw & Format(wsCriteia.Range("D6").Offset _
(Split(NewComb, SepChar)(i - 1)), "00") & SepChar
Next
'***********************************************************
wsResults.Cells(1, 1).Offset(((Counter1 - 1) Mod myWrap), _
Int((Counter1 - 1) / myWrap)) = Left(MyDraw, Len(MyDraw) - Len(SepChar))
CountOff(BallsDrawn) = CountOff(BallsDrawn) + 1
Dummy = BallsDrawn
While Dummy > 1
If CountOff(Dummy) > MaxOff(Dummy) Then
CountOff(Dummy - 1) = CountOff(Dummy - 1) + 1
For Counter2 = Dummy To BallsDrawn
CountOff(Counter2) = CountOff(Counter2 - 1) + 1
Next Counter2
End If
Dummy = Dummy - 1
Wend
Next Counter1
.Cells.EntireColumn.AutoFit
.Cells.EntireColumn.HorizontalAlignment = xlCenter
.Activate
.Range("A1").Select
End With
End With
With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub
... I think the problem lies within the Asterisks but for the life of me I cannot get it to ouput the results in the correct format.
Thanks in advance.
Kind regards,
PAB