PDA

View Full Version : Solved: Formatting Output As Double Digits



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

mdmackillop
01-08-2012, 03:11 PM
Excel is defaulting to numeric values.
You could
1. Format the cells as text.
or
2. For "1", set custom formatting to "00"; for "2", set custom formatting to "00.00"

PAB
01-08-2012, 04:06 PM
Thanks for the reply MD,

I added an "If Then Else" statement ...


.Cells.ClearContents
If BallsDrawn = 1 Then
.Cells.NumberFormat = "00"
Else
.Cells.NumberFormat = "00.00"
End If
SepChar = "."


... and now it works.
I thought that now I could take out any other formatting referencing the structure of the combination like the Format "00" ...


For i = 1 To BallsDrawn
MyDraw = MyDraw & Format(wsCriteia.Range("D6").Offset _
(Split(NewComb, SepChar)(i - 1)), "00") & SepChar
Next

... but I can't as it will not work correctly.
It is strange though that I only had to include formatting in the "If Then Else" statement if "BallsDrawn" were one or two and not for anything higher.
Thanks for your help.

Kind regards,
PAB

mdmackillop
01-08-2012, 04:31 PM
Anything containing two or more "." will be interpreted as text, so the issue will not arise.

PAB
01-08-2012, 06:48 PM
Thanks for the reply and explanation MD.
One final request please. I have seen posts in the past that suggest it is better to set ranges and variables rather than actually use them within the code itself.
I have adapted the code below as you can see for two out of the three ranges used and it works great. Unfortunately I can't seem to get the "BallsDrawnFrom" to work.
Any help will be greatly appreciated.
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 BallsDrawn As Long ' The length of EACH individual combination.

Dim BallsDrawnFrom As Long ' The total number to be drawn from.
Dim MyDraw As String
Dim i As Long
Dim wsCriteia As Worksheet
Dim wsResults As Worksheet
Set wsCriteia = Worksheets("Criteria")
Set wsResults = Worksheets("Results")

Dim BallsDrawn As Range
Set BallsDrawn = Worksheets("Criteria").Range("D6")

Dim CriteriaStart As Range
Set CriteriaStart = Worksheets("Criteria").Range("D7")

' Dim BallsDrawnFrom As Range
' Set BallsDrawnFrom = Worksheets("Criteria").Range(.Cells(9, 3), .Cells(9, 3).End(xlDown)).Cells.Count

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
If BallsDrawn = 1 Then
.Cells.NumberFormat = "00"
Else
.Cells.NumberFormat = "00.00"
End If
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(CriteriaStart _
(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
Thanks in advance.

Kind regards,
PAB

PAB
01-08-2012, 10:33 PM
Hi MD,

I managed to get it working by using ...


Dim BallsDrawnFrom As Long
BallsDrawnFrom = Application.WorksheetFunction.CountIf(Range("D7:D100"), ">0")
... but unfortunately could not get it to work using ...


.End(xlDown)).Cells.Count
Is it better to put the ...


BallsDrawnFrom = Application.WorksheetFunction.CountIf(Range("D7:D100"), ">0")
... after the "With wsCriteia" but before the "With wsResults" or before the "With wsCriteia" please.

Anyway, here is the finished code.
If you can see anything wrong with it or it could be improved in some way I would appreciate your comments.


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
Dim MyDraw As String
Dim i As Long
Dim wsCriteia As Worksheet
Dim wsResults As Worksheet
Dim BallsDrawn As Range
Dim BallsDrawnFrom As Long
Dim CriteriaStart As Range
Set wsCriteia = Worksheets("Criteria")
Set wsResults = Worksheets("Results")
Set BallsDrawn = Worksheets("Criteria").Range("D6")
Set CriteriaStart = Worksheets("Criteria").Range("D7")
BallsDrawnFrom = Application.WorksheetFunction.CountIf(Range("D7:D100"), ">0")
myWrap = 1000
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
With wsCriteia
.Activate
.Range("B57").Select
With wsResults
.Cells.ClearContents
If BallsDrawn = 1 Then
.Cells.NumberFormat = "00"
Else
.Cells.NumberFormat = "00.00"
End If
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(CriteriaStart _
(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
Thanks in advance.

Kind regards,
PAB

PAB
01-11-2012, 06:28 AM
Hi MD,

I am going to mark this thread as "Solved".
Thanks for ALL your time and help on this, it is appreciated.

Kind regards,
PAB
:yes