Excel VBA Adding Zero in Number String

[Guna13]

Since I am only new to Visual Basic, I don't know much about programming. I have now manually processed this work.

In my Organization Fin Companies 001 to 999 Order, I download the Master dump file from the ERP system. Rather than showing all <100 Fin Companies, it shows only two digits instead of three digits

To update '002 or '083 or '088 in this format, I need to update ('xxx) this format manually. What is the best way to update this format via VBA. I have more than 3 laksh lines in my Master data dump at the moment

This Special format didn't work for my formula when I tried that General function.

Fin Comp
12
23
34
98
234
344
434
233
848
999
343

I need output should be

Fin Comp
'012
'023
'034
'098
234
344
434
233
848
999
343

 

[jasonb75]

Try using a custom format of 000 for those cells. No vba needed.

 

[Biz]

Vba Solution

Dim aStartTime
Dim ProcName As String
Dim bErrorHandle As Boolean
Const DblSpace As String = vbNewLine & vbNewLine
Const CoName As String = "Pading Text"

Sub PadText()
          Dim v As Long, vLWRs As Variant, vLWRs1
          Dim rng As Range
          Dim iCount As Long
          Dim NumOfDigits As Long
          Dim rngLen As Long
          Dim rngValue As String
          Dim strText As String
          Const cNumOfDigits As Long = 3
          Const cText As String = "0"
         
1         On Error GoTo errhandler
2         bErrorHandle = False
         
          '~~> Code Starts from here
3         With ActiveSheet
              '~~> Define the selected range
4             Set rng = Selection
             
              '~~> Capture users numbers of digits which is padded with leading zeros
5             NumOfDigits = Application.InputBox( _
                  "Enter a numeric value indicated the desired length of data in characters:", _
                  "Enter Target Cell Length", cNumOfDigits, Type:=1)
              '~~> Detect Cancel
6             If NumOfDigits = 0 Then
7                 MsgBox "Operation Aborted", vbInformation + vbMsgBoxSetForeground
8                 Exit Sub
9             End If
             
              '~~> Capture users Text which is padded with leading Text
10            strText = Application.InputBox("Enter the text to pad to:", "Enter Text", cText)
              '~~> Detect Cancel
11            If strText = vbNullString Then
12                MsgBox "Operation Aborted", vbInformation + vbMsgBoxSetForeground
13                Exit Sub
14            End If
             
             
              '~~> Start Timer
15            aStartTime = Now()
             
              '~~> Speeding Up VBA Code
16            Call SpeedUp(False)
             
17            With rng
18                If .Cells.Count > 1 Then
                      '~~> Change number format to Text
19                    .NumberFormat = "@"
                      '~~> Pass values from Spreadsheet to an array to conduct processing faster
                      '~~>  Creates Variant(1 to 2, 1 to 1)
20                    vLWRs = .Value
                      '~~> Loop thru array in computer memory and round numbers
21                    For v = LBound(vLWRs, 1) To UBound(vLWRs, 1)
22                        rngValue = vLWRs(v, 1) '.Value
23                        rngLen = VBA.Len(rngValue)
                          '~~> Update items in array
24                        On Error GoTo qSkip1
25                        vLWRs(v, 1) = VBA.String$(NumOfDigits - rngLen, strText) & rngValue
                          'Application.Text(vLWRs(v, 1), Application.Rept(strText, NumOfDigits))
qSkip1:
26                    Next v
                      '~~> Write Array To Spreadsheet
27                    .Cells = vLWRs
28                Else
                      '~~> Redim array size to 1 (only 1 cell in range)
29                    ReDim vLWRs(0 To rng.Cells.Count - 1)
                      '~~> Change number format to Text
30                    .NumberFormat = "@"
31                    On Error GoTo qSkip2
32                    vLWRs(0) = VBA.String$(NumOfDigits - Len(rng), strText) & rng.Value
                     
                      '~~> Pass it back to the cells
33                    rng = vLWRs
qSkip2:
34                End If
35            End With
             
36        End With
37        iCount = rng.Rows.Count
          '~~> Code Ends
         
BeforeExit:
          '~~> Remove items from memory
38        Set rng = Nothing
         
          '~~> Speeding Up VBA Code
39        Call SpeedUp(True)
         
40        If bErrorHandle = False Then
             
              '~~> No Errors
41            MsgBox "No of Records - " & Format(iCount, "#,##0;[Red](#,##0);-_)") & DblSpace _
                  & "Time taken: " & Format(Now() - aStartTime, "h:mm:ss") & DblSpace _
                  & " You're good to go!" & DblSpace & _
                  CoName & Chr(32) & Chr(169) & Chr(32) & Year(Date), vbInformation, "Excellent"
42        End If
43        Exit Sub
          '~~> Error Occurred
errhandler:
44        bErrorHandle = True
45        ProcName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
46        MsgBox IIf(Erl = 0, "", "Error on line " & Erl) & vbNewLine & "Procedure: - " & ProcName & vbNewLine & "Error " & Err.Number & " " & Err.Description, vbCritical, "Oops I did it again...."
          'MsgBox "Procedure: - " & ProcName & DblSpace & Err.Description, vbCritical, "Oops I did it again...."
47        Resume BeforeExit
End Sub


'#### SpeedUp (False) - Speeds the VBA Code #####
'#### SpeedUp (True) - Slows down the VBA Code ####
Public Function SpeedUp(Optional bSpeed As Boolean = True)
With Application
    .ScreenUpdating = bSpeed 'Prevent screen flickering
    '.Calculation = IIf(bSpeed, xlAutomatic, xlCalculationManual) 'Preventing calculation
    .DisplayAlerts = bSpeed 'Turn OFF alerts
    .EnableEvents = bSpeed 'Prevent All Events
    .Cursor = IIf(bSpeed, xlDefault, xlWait) 'Prevent Hour Glass
    .StatusBar = IIf(bSpeed, vbNullString, "Please wait...")
    '.Application.Interactive = bSpeed 'Block all input from the keyboard and mouse
End With
End Function

 

[Alex Blakenburg]

You certainly need to decide whether you want the company number to be a number or text. If you want it to stay a number then Jason's suggestion should work for you.
If you want it to be text then here is another code version.
Change references to Column A to the column of your company code.

Sub PadOutCoyNumber()

    Dim sht As Worksheet
    Dim lastRow As Long
    Dim rng As Range
  
    Application.ScreenUpdating = False
  
    Set sht = ActiveSheet
    lastRow = sht.Range("A" & Rows.Count).End(xlUp).Row
    Set rng = sht.Range("A2:A" & lastRow)
  
    rng.NumberFormat = "@"
    rng = Application.Text(rng.Value, "000")
  
    Application.ScreenUpdating = True

End Sub

 

[Guna13]

Great

You certainly need to decide whether you want the company number to be a number or text. If you want it to stay a number then Jason's suggestion should work for you.
If you want it to be text then here is another code version.
Change references to Column A to the column of your company code.

Sub PadOutCoyNumber()

    Dim sht As Worksheet
    Dim lastRow As Long
    Dim rng As Range
 
    Application.ScreenUpdating = False
 
    Set sht = ActiveSheet
    lastRow = sht.Range("A" & Rows.Count).End(xlUp).Row
    Set rng = sht.Range("A2:A" & lastRow)
 
    rng.NumberFormat = "@"
    rng = Application.Text(rng.Value, "000")
 
    Application.ScreenUpdating = True

End Sub

Great website. And Great Expert. Thanks sir...

 

[Alex Blakenburg]

Glad we could help & thanks for the feedback.

 

[Guna13]

Thanks a lot for your great Clarification and Code. last Pain area for me.

In Activeworkbook I have below sheets
1.Baan ETB
2.Interim Master Data
3.Interim Acc Validation

I have to Update in "Interim Acc Validation" sheets, Respective MEP_Code Lines in Range("B4:E4") .

(MEP_Code Value available in ("Baan ETB") Sheets Range.P2.

Unable to do this VBA code this task. kindly help me sir.. when i run this code. my MEP_Code Value shows "Blank instead of Value. Kindly help and fix this code sir.

Sub Interim_Acc1()

Dim wss, wss1, wss2, wss3, wss4 As Worksheet
Dim rgdata As Range, rgcriteria As Range, rgoutput As Range
Dim rg As Range


Set wss1 = ThisWorkbook.Sheets("Interim Acc Validation")
Set wss2 = ThisWorkbook.Sheets("Baan ETB")
Set wss4 = ThisWorkbook.Sheets("Info")
Set Trg = ThisWorkbook.Sheets("Interim Master Data")
Set rrr = ThisWorkbook.Sheets("30 FDSS VALIDATION")

wss1.Unprotect password:="1234"

Set rg = ThisWorkbook.Sheets("Interim Acc Validation").Range("A4:H10000")
rg.Clear

wss2.Select
Set rng = wss2.Range("P2:P10000")
With rng
    .Value = Evaluate(Replace("If(@="""","""",Trim(@))", "@", .Address))
End With

mep = wss2.Range("P2").Value

Trg.AutoFilterMode = False
If mep <> "" Then

    Sheets("Interim Master Data").Range("A1:E10000").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Baan ETB").Range("P1:P2"), _
        CopyToRange:=Sheets("Interim Acc Validation").Range("A4"), Unique:=False

wss1.Activate
wss1.Rows(4).EntireRow.Delete
lr = wss1.Range("A" & Rows.Count).End(xlUp).Row


Sheets("Interim Acc Validation").Range("A1").Value = UCase(mep)[/B]

 With Sheets("Interim Acc Validation").Cells.Font
        .Name = "Calibri"
        .Size = 9
    End With
 
End Sub

 

[Alex Blakenburg]

I'm afraid that is a new question and will require a new thread.

 

[Guna13]

I'm afraid that is a new question and will require a new thread.

i posted new thread sir.. kindly support me sir.. plz

 

[Alex Blakenburg]

I am login off for the night, hopefully someone in a different time zone will pick it up overnight.