Code needs some cleaning

[N_Mitch]

G'day all,

I have a form which converts and copies 10,000 whole numbers into binary. This is repeated 5 times (see below for rationale).

The code puts the whole number in, say, A12, then the Binary into B12. If the binary number length is less than 20 characters, zeros are placed in front of the first 1 so the text length is 20. Each digit of the binary number (0 or 1) is then placed in cells C12 to V12.

If the first number is 1, then the first row (i.e. A12:V12) =

1 00000000000000000001 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1

For those who are obviously wondering "Why would anyone want to do that!?", this sheet is then used by another programme which links to this workbook and uses these whole and binary numbers to print onto sheets.

This programme is used by a printing business to create 50,000 tickets (5 up on each sheet, 2,000 numbers per column on each sheet).

Anyway, I thought I'd need to do some explaining before showing my code.

My code works very, very well; however, it runs very slow. I fully realise the progress bar slows things down, but wanted the user to know the code is not freezing (I have assumed - rightly or wrongly - that this code will take some time to crunch through anyway).

Here is the code for the UserForm. All the user has to do before clicking the command button is to enter the beginning number:

Private Sub CommandButton3_Click()
    Application.ScreenUpdating = False
    Dim strDecimal As String
    Dim i As Long
    Dim j As Integer, k As Integer, l As Integer, m As Integer
    Dim ws As Worksheet
    Dim intRepeat As Long
    Dim intDecimal As Long
    Dim intIndex As Long
    Dim sngPercent As Single
    Dim intLeadingZeros As Integer
    On Error GoTo ErrorHandler
    labPg1.Visible = True
    labPg1a.Visible = True
    labPg1v.Visible = True
    labPg1va.Visible = True
    If Not IsNumeric(txtDecimal) Then
        MsgBox "You must enter a numeric value!", vbCritical, "INPUT ERROR"
        txtDecimal.SetFocus
        Exit Sub
    End If
    txtRepeat.Value = 10000
    If Not IsNumeric(txtRepeat) Then
        MsgBox "You must enter a numeric value!", vbCritical, "INPUT ERROR"
        txtRepeat.SetFocus
        Exit Sub
    End If
    intRepeat = 10000
    i = 1
    intDecimal = CLng(txtDecimal)
    Do While i <= intRepeat
        For intIndex = 1 To intRepeat
            sngPercent = intIndex / intRepeat
            ProgressStyle1 sngPercent, chkPg1Value.Value
            DoEvents
            strDecimal = CStr(intDecimal)
            strDecimal = DecToBin(CStr(intDecimal))
            If Len(strDecimal) <= 20 Then
                intLeadingZeros = 20 - Len(strDecimal)
            End If
            For j = 1 To intLeadingZeros
                strDecimal = 0 & strDecimal
            Next j
            l = LastRowInColumn(1)
            m = LastRowInColumn(2)
            Range("A" & l + 1) = intDecimal
            Range("B" & l + 1) = strDecimal
            For k = 1 To 20
                If Mid(strDecimal, k, 1) = 1 Then Cells(l + 1, k + 2) = "n"
            Next k
            With Range("B" & l)
                .TextToColumns Destination:=Range("B" & l), _
                    DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                    ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
                    Comma:=False, Space:=False, Other:=False, FieldInfo _
                    :=Array(1, 2), TrailingMinusNumbers:=True
            End With
            i = i + 1
            intDecimal = intDecimal + 1
        Next
    Loop
    'ActiveSheet.PageSetup.PrintArea = "A1:B" & l
    txtDecimal = 0
    'txtRepeat = 0
    Me.Hide
    Application.Cursor = xlDefault
    labPg1.Visible = False
    labPg1a.Visible = False
    labPg1v.Visible = False
    labPg1va.Visible = False
    Application.ScreenUpdating = True
    Exit Sub
ErrorHandler:
MsgBox "This operation has caused an unknown problem." & vbCrLf & _
    "Please notify Derek Mitchell about this error.", vbCritical, "ABORT CALCULATION"
Application.ScreenUpdating = True
Range("A1").Select
Me.Hide
Application.Cursor = xlDefault
    Application.ScreenUpdating = True
Exit Sub
End Sub

Sub ProgressStyle1(Percent As Single, ShowValue As Boolean)
'
' Progress Style 1
' Label Over Label
'
    Const PAD = "                         "
    labPg1v.Caption = PAD & Format(Percent, "0%")
    labPg1va.Caption = labPg1v.Caption
    labPg1va.Width = labPg1.Width
    labPg1.Width = Int(labPg1.Tag * Percent)
End Sub

Private Sub chkPg1Value_Click()
    labPg1v.Visible = chkPg1Value.Value
    labPg1va.Visible = chkPg1Value.Value
End Sub

Here are the procedures in Module1:

Public Function DecToBin(DecNum As String) As String
   Dim BinNum As String
   Dim lDecNum As Long
   Dim i As Integer
   On Error GoTo ErrorHandler
'  Check the string for invalid characters
   For i = 1 To Len(DecNum)
      If Asc(Mid(DecNum, i, 1)) < 48 Or _
         Asc(Mid(DecNum, i, 1)) > 57 Then
         BinNum = ""
         Err.Raise 1010, "DecToBin", "Invalid Input"
      End If
   Next i
   i = 0
   lDecNum = Val(DecNum)
   Do
      If lDecNum And 2 ^ i Then
         BinNum = "1" & BinNum
      Else
         BinNum = "0" & BinNum
      End If
      i = i + 1
   Loop Until 2 ^ i > lDecNum
'  Return BinNum as a String
   DecToBin = BinNum
ErrorHandler:
End Function

Function LastRowInColumn(intCol As Long) As Long
    On Error GoTo LRICError
    Application.Volatile 'This will make sure that this function is called if anything is changed on the Worksheet
    LastRowInColumn = Cells(Rows.Count, intCol).End(xlUp).Row
ExitFnxn:
    Exit Function
    'If there's an error in this function, then return an error to Excel
LRICError:
    LastRowInColumn = CInt(CVErr(xlErrNA))
    Resume ExitFnxn
End Function

Any help would be appreciated

 

[N_Mitch]

Just a further word of explanation. txtDecimal and txtRepeat are actually text boxes. While the user only inputs into txtDecimal, I originally allowed the user to input how many binary numbers were needed. While this is now fixed, I wanted to keep this option open for future use. txtRepeat is not visible on the UserForm.

Thanks again (in advance),

Mitch