VBA Code Efficiency Advice Needed - excel

For very large Excel csv files (can be as large as 35MB+ & >100k rows), one of my processing steps is to check column A's "record type" indicator and depending on the value, cut/paste 2 sequential cells from different places in the row, over to the end of the row (columns 51 & 52).
The following code passed the 'CompileVBAProject' test, but I'm certain there are more efficient, much faster scripts that I'm just not thinking of. Yes, I'm a VBA semi-noob, but I'm trying to get better fast. Got any advice?
For i = 4 To rng.Rows.Count
If Cells(i, 1).Value = "10EE" Then
Range("AW" & i & ":AY" & i).Copy Cells(i, 50)
Range("AW" & i).ClearContents
Else
If Cells(i, 1).Value = "05EE" Then
Range("M" & i & ":N" & i).Copy Cells(i, 51)
Range("M" & i & ":N" & i).ClearContents
Else
If (Cells(i, 1).Value = "11EE" Or Cells(i, 1).Value = "25CP" Or Cells(i, 1).Value = "26EP" _
Or Cells(i, 1).Value = "51CL" Or Cells(i, 1).Value = "60PM") Then
Range("L" & i & ":M" & i).Copy Cells(i, 51)
Range("L" & i & ":M" & i).ClearContents
Else
If Cells(i, 1).Value = "15EM" Then
Range("M" & i & ":N" & i).Copy Cells(i, 51)
Range("M" & i & ":N" & i).ClearContents
Else
If Cells(i, 1).Value = "17EA" Then
Range("X" & i & ":Y" & i).Copy Cells(i, 51)
Range("X" & i & ":Y" & i).ClearContents
Else
If Cells(i, 1).Value = "20DP" Then
Range("AC" & i & ":AD" & i).Copy Cells(i, 51)
Range("AC" & i & ":AD" & i).ClearContents
Else
If Cells(i, 1).Value = "24AH" Then
Range("AD" & i & ":AE" & i).Copy Cells(i, 51)
Range("AD" & i & ":AE" & i).ClearContents
Else
If Cells(i, 1).Value = "30EL" Then
Range("V" & i & ":W" & i).Copy Cells(i, 51)
Range("V" & i & ":W" & i).ClearContents
Else
If Cells(i, 1).Value = "31EL" Then
Range("O" & i & ":P" & i).Copy Cells(i, 51)
Range("O" & i & ":P" & i).ClearContents
Else
If Cells(i, 1).Value = "40DE" Then
Range("R" & i & ":S" & i).Copy Cells(i, 51)
Range("R" & i & ":S" & i).ClearContents
Else
If Cells(i, 1).Value = "50CL" Then
Range("AB" & i & ":AC" & i).Copy Cells(i, 51)
Range("AB" & i & ":AC" & i).ClearContents
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next i

If you are using Set rng = Application.Range("A4:A" & lrow) then For i = 4 To rng.Rows.Count is incorrect.
A Select Case seems ideal for this. I combined "05EE" and "15EM".
with worksheets(1)
For i = 4 To lrow
Select Case .Cells(i, 1).Value2
Case "10EE"
.Cells(i, "AX").Resize(1, 3) = .Cells(i, "AW").Resize(1, 3).Value2
.Cells(i, "AW").ClearContents
Case "05EE", "15EM"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "M").Resize(1, 2).Value2
.Cells(i, "M").Resize(1, 2).ClearContents
Case "11EE", "25CP", "26EP", "51CL", "60PM"
.Cells(i, "AY").Resize(1, 3) = .Cells(i, "L").Resize(1, 3).Value2
.Cells(i, "L").Resize(1, 3).ClearContents
Case "17EA"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "X").Resize(1, 2).Value2
.Cells(i, "X").Resize(1, 2).ClearContents
Case "20DP"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AC").Resize(1, 2).Value2
.Cells(i, "AC").Resize(1, 2).ClearContents
Case "24AH"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AD").Resize(1, 2).Value2
.Cells(i, "AD").Resize(1, 2).ClearContents
Case "30EL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "V").Resize(1, 2).Value2
.Cells(i, "V").Resize(1, 2).ClearContents
Case "31EL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "O").Resize(1, 2).Value2
.Cells(i, "O").Resize(1, 2).ClearContents
Case "40DE"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "R").Resize(1, 2).Value2
.Cells(i, "R").Resize(1, 2).ClearContents
Case "50CL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AB").Resize(1, 2).Value2
.Cells(i, "AB").Resize(1, 2).ClearContents
Case Else
'do nothing
End Select
Next i
end with
If there are certain values that occur more frequently, they should be at the top of the Case conditions.

Another way to structure the data, and use arrays:
Option Explicit
Public Sub CopyVals()
Const START_ROW = 4
Dim ws As Worksheet, rng As Range, map As Variant, arr As Variant, mapUb As Long
Set ws = Sheet3 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
Set rng = ws.UsedRange
arr = rng 'Copy Range to Array
map = GetMapping(map) 'Get Mapping: Values to Columns
mapUb = UBound(map)
Dim r As Long, i As Long, j As Long
For r = START_ROW To rng.Rows.Count
For i = 1 To mapUb
If arr(r, 1) = map(i, 1) Then
For j = 0 To map(i, 4) 'map4 = Offset col
' map3 = copyTo col map2 = copyFrom col
arr(r, map(i, 3) + j) = arr(r, map(i, 2) + j)
Next
End If
Next
Next
rng.Offset(rng.Rows.Count + 1, 0) = arr
End Sub
Private Function GetMapping(ByRef map As Variant) As Variant
Const ITM = "10EE 05EE 11EE 25CP 26EP 51CL 60PM 15EM 17EA 20DP 24AH 30EL 31EL 40DE 50CL"
Const SRC = "49 13 12 12 12 12 12 13 24 29 30 22 15 18 28"
Const DST = "50 51 51 51 51 51 51 51 51 51 51 51 51 51 51"
Const OFF = "2 1 1 1 1 1 1 1 1 1 1 1 1 1 1" 'Total columns to copy From / To + 1
Dim v As Variant, s As Variant, d As Variant, o As Variant, i As Long
v = Split(ITM)
s = Split(SRC)
d = Split(DST)
o = Split(OFF)
ReDim map(1 To UBound(v) + 1, 1 To 4) As Variant
For i = 1 To UBound(v) + 1
map(i, 1) = v(i - 1) 'Values
map(i, 2) = s(i - 1) 'From First Col
map(i, 3) = d(i - 1) 'To First Col
map(i, 4) = o(i - 1) 'Total Cols (both From and To)
Next
GetMapping = map
End Function
.
Map Array returned by GetMapping()
Value From First Col To First Col Total Cols (+ 1)
map( 1, 1) = "10EE": map( 1, 2) = 49: map( 1, 3) = 50: map( 1, 4) = 2
map( 2, 1) = "05EE": map( 2, 2) = 13: map( 2, 3) = 51: map( 2, 4) = 1
map( 3, 1) = "11EE": map( 3, 2) = 12: map( 3, 3) = 51: map( 3, 4) = 1
map( 4, 1) = "25CP": map( 4, 2) = 12: map( 4, 3) = 51: map( 4, 4) = 1
map( 5, 1) = "26EP": map( 5, 2) = 12: map( 5, 3) = 51: map( 5, 4) = 1
map( 6, 1) = "51CL": map( 6, 2) = 12: map( 6, 3) = 51: map( 6, 4) = 1
map( 7, 1) = "60PM": map( 7, 2) = 12: map( 7, 3) = 51: map( 7, 4) = 1
map( 8, 1) = "15EM": map( 8, 2) = 13: map( 8, 3) = 51: map( 8, 4) = 1
map( 9, 1) = "17EA": map( 9, 2) = 24: map( 9, 3) = 51: map( 9, 4) = 1
map(10, 1) = "20DP": map(10, 2) = 29: map(10, 3) = 51: map(10, 4) = 1
map(11, 1) = "24AH": map(11, 2) = 30: map(11, 3) = 51: map(11, 4) = 1
map(12, 1) = "30EL": map(12, 2) = 22: map(12, 3) = 51: map(12, 4) = 1
map(13, 1) = "31EL": map(13, 2) = 15: map(13, 3) = 51: map(13, 4) = 1
map(14, 1) = "40DE": map(14, 2) = 18: map(14, 3) = 51: map(14, 4) = 1
map(15, 1) = "50CL": map(15, 2) = 28: map(15, 3) = 51: map(15, 4) = 1

Related

Macro doesn't run same on my PC as it runs on another

I have written a VBA macro for automating part of my work. It was written on laptop which is based on Russian (date/keyboard) settings.
Somehow when I run it on external PC ( based on German in Austria ) It doesn't perform the same way, it gives me wrong results and error - 'run time error '13' type mismatch'
Sub Proverka()
nm = ActiveSheet.Name
Sheets.Add.Name = "mediana"
Worksheets(nm).Select
n = Cells(Rows.Count, 1).End(xlUp).Row
Summa = 0
Kol = 0
k = 1
For i = 2 To n
Cells(i, 4) = Replace(Cells(i, 4), " Days", "")
If Cells(i, 1) = "Resolved-Issued" And Format(Cells(i, 2), "mmmm") = Format(DateAdd("m", -1, Date), "mmmm") And Format(Cells(i, 2), "yyyy") = Format(DateAdd("m", -1, Date), "yyyy") And Cells(i, 13) = "TFO" Then
If Cells(i, 5) <> "" Then KolD = DateDiff("d", Cells(i, 3), CDate(Split(Cells(i, 5), "/")(1) & "." & Split(Cells(i, 5), "/")(0) & "." & Split(Cells(i, 5), "/")(2)))
KolDV = 0
D = CDate(Cells(i, 3))
For i2 = 1 To KolD
If Format(D, "dddd") = "saturday" Or Format(D, "dddd") = "sunday" Then
KolDV = KolDV + 1
End If
D = DateAdd("d", 1, D)
Next i2
Cells(i, 4) = Cells(i, 4) - KolDV
Worksheets("mediana").Cells(k, 1) = Cells(i, 4)
k = k + 1
End If
Next i
Cells(n + 2, 1) = "Median " & Format(DateAdd("m", -1, Date), "mmmm")
Cells(n + 3, 1) = "Average " & Format(DateAdd("m", -1, Date), "mmmm")
a = WorksheetFunction.Average(Range(Worksheets("mediana").Cells(1, 1), Worksheets("mediana").Cells(k - 1, 1)))
m = WorksheetFunction.Median(Range(Worksheets("mediana").Cells(1, 1), Worksheets("mediana").Cells(k - 1, 1)))
'Worksheets("mediana").Delete
Cells(n + 2, 4) = m
Cells(n + 3, 4) = a
MsgBox "OK"
End Sub

Check checkbox value only once inside a nested loop

I am checking the value of a checkbox on my userform inside a nested loop. I want to know if there is a way to do this before the loops because basically the code is running the same check over and over again...
what it is doing is it loops through the entire column B and combines all the rows that have the same conditions. then it puts in into an array and prints. So I need to do this checkbox check twice. Any help is appreciated!
Dim dict As Object
Dim LastRow As Long
Dim aCell As Range
Dim ArrayLen As Long
Dim LArr() As Single
Dim MPch As Boolean
MPch = UserForm1.MPCheck1.Value
Set dict = CreateObject("scripting.dictionary")
X = 0
With wks
LastRow = .Cells(.Rows.Count, "B").End(xlUp).row
ReDim LArr(LastRow)
For Each aCell In .Range("B2:B" & LastRow)
If MPch = True Then
UniqueCombo = aCell.Value & "," & aCell.Offset(0, 1) & aCell.Offset(0, 2)
Else
UniqueCombo = aCell.Value & "," & aCell.Offset(0, 1) & aCell.Offset(0, 2) & "," & aCell.Offset(0, 5)
End If
DieCoordinate = aCell.Value & "," & aCell.Offset(0, 1)
SheetName = aCell.Offset(0, 2) & "-" & aCell.Offset(0, 5)
If Not dict.exists(UniqueCombo) Then
VarLastRow = ThisWorkbook.Worksheets(SheetName).Cells(.Rows.Count, "E").End(xlUp).row + 1
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 5) = DieCoordinate
dict(UniqueCombo) = True 'add this value
For o = 2 To LastRow
If MPch = True Then
VariableCombo = .Cells(o, 2) & "," & .Cells(o, 3) & .Cells(o, 4)
Else
VariableCombo = .Cells(o, 2) & "," & .Cells(o, 3) & .Cells(o, 4) & "," & .Cells(o, 7)
End If
VariableCombo = .Cells(o, 2) & "," & .Cells(o, 3) & .Cells(o, 4) & "," & .Cells(o, 7)
If UniqueCombo = VariableCombo And .Cells(o, 6).Interior.ColorIndex = -4142 And _
.Cells(o, 6) <> "*" And .Cells(o, 6) <> "0" And .Cells(o, 6) <> "" Then
CDTot = CDTot + .Cells(o, 6)
LArr(X) = .Cells(o, 6)
X = X + 1
End If
Next
If X = 0 Then
ArrayLen = 0
Else
ReDim Preserve LArr(UBound(LArr) - (LastRow - X + 1))
ArrayLen = UBound(LArr) - LBound(LArr) + 1
End If
If ArrayLen < UserForm1.TextBox7 Then
ThisWorkbook.Worksheets(SheetName).Range(ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 5), ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 10)).Interior.ColorIndex = 53
End If
LCDUCD = 3 * Application.WorksheetFunction.StDev_P(LArr)
DieAver = Application.WorksheetFunction.Average(LArr)
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 7) = LCDUCD
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 6) = DieAver
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 8) = aCell.Value
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 9) = aCell.Offset(0, 1).Value
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 10) = ArrayLen
End If
ReDim LArr(LastRow)
X = 0
Next aCell
End With

Suggestions to speed up/improve this VBA script?

Any suggestions or tips to make this run better? I have used it on smaller data sets (100-1000 rows) and it works perfectly. Trying to run it on a data set of about 100,000 rows and it results in unresponsiveness while running and me having to force quit excel.
Sub CombineSchARecords()
Dim myRow As Long
'Row data starts
myRow = 2
Application.ScreenUpdating = False
'Loop until out of data
Do Until Cells(myRow, "A") = ""
'Check to see if next row is for same filing number
If Cells(myRow, "A") = Cells(myRow + 1, "A") Then
'Add data to correct column
Cells(myRow, "B") = Cells(myRow, "B") & ", " & Cells(myRow + 1, "B") 'SchA-3
Cells(myRow, "C") = Cells(myRow, "C") & ", " & Cells(myRow + 1, "C") 'Schedule
Cells(myRow, "D") = Cells(myRow, "D") & " | " & Cells(myRow + 1, "D") 'Full Legal Name
Cells(myRow, "E") = Cells(myRow, "E") & ", " & Cells(myRow + 1, "E") 'DE/FE/I
Cells(myRow, "F") = Cells(myRow, "F") & ", " & Cells(myRow + 1, "F") 'Entity in Which
Cells(myRow, "G") = Cells(myRow, "G") & ", " & Cells(myRow + 1, "G") 'Title or Status
Cells(myRow, "H") = Cells(myRow, "H") & ", " & Cells(myRow + 1, "H") 'Status Aquired
Cells(myRow, "I") = Cells(myRow, "I") & ", " & Cells(myRow + 1, "I") 'Ownership Code
Cells(myRow, "J") = Cells(myRow, "J") & ", " & Cells(myRow + 1, "J") 'Control Person
Cells(myRow, "K") = Cells(myRow, "K") & ", " & Cells(myRow + 1, "K") 'PR
Cells(myRow, "L") = Cells(myRow, "L") & ", " & Cells(myRow + 1, "L") 'OwnerID
'Then delete row
Rows(myRow + 1).Delete
Else
myRow = myRow + 1 'Move down one row if no match
End If
Loop
Application.ScreenUpdating = True
End Sub
Thanks!
The standard way to get a good speedup is to in one statement read everything into one big VBA array, process that array in VBA and then put the result back into the spreadsheet in another statement. Two lines of code which touch the spreadsheet, rather than 100,000+ spreadsheet read/writes in a loop
In terms of your problem this would mean something like:
Sub CombineSchARecords()
Dim n As Long, i As Long, j As Long
Dim numRecords As Long
Dim Values As Variant, Processed As Variant
n = Cells(Rows.Count, 1).End(xlUp).Row
Values = Range(Cells(2, "A"), Cells(n, "K")).Value
ReDim Processed(1 To n - 1, 1 To 11)
'initialize first row of Processed
For j = 1 To 11
Processed(1, j) = Values(1, j)
Next j
numRecords = 1
'main loop
For i = 2 To n - 1
If Values(i, 1) = Processed(numRecords, 1) Then
For j = 2 To 11
Processed(numRecords, j) = Processed(numRecords, j) & IIf(j = 4, " | ", ", ") & Values(i, j)
Next j
Else 'start processing a new record
numRecords = numRecords + 1
For j = 1 To 11
Processed(numRecords, j) = Values(i, j)
Next j
End If
Next i
'redim Values and copy records over
ReDim Values(1 To numRecords, 1 To 11)
For i = 1 To numRecords
For j = 1 To 11
Values(i, j) = Processed(i, j)
Next j
Next i
'finally:
Range(Cells(2, "A"), Cells(n, "K")).ClearContents
Range(Cells(2, "A"), Cells(numRecords + 1, "K")).Value = Values
End Sub
Besides of the use VBA array to define your variable, you may use below code to speedup your script as well.
Application.Calculation = xlManual
'Your code between this
Application.Calculation = xlAutomatic

Have any other ways to combine strings of same item?

I would like to ask how to shorten the code below? Have any other ways to achieve the same result?
Option Explicit
Sub test()
Dim i As Integer
Dim nRow As Integer: nRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To nRow
If Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) And Cells(i + 3, 1) = Cells(i + 4, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2) & "/" & Cells(i + 4, 2)
Rows(i + 1 & ":" & i + 4).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2)
Rows(i + 1 & ":" & i + 3).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2)
Rows(i + 1 & ":" & i + 2).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2)
Rows(i + 1 & ":" & i + 1).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) = "" Then
Exit For
End If
Next i
End Sub
Thank you!
Here's Dictionary based approach which should work for you.
Public Sub RearrangeData()
Dim objDic As Object
Dim varRng
Dim i As Long
Set objDic = CreateObject("Scripting.Dictionary")
objDic.CompareMode = vbTextCompare '\\ change this if you need it case sensitive
varRng = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
For i = LBound(varRng) To UBound(varRng)
If objDic.Exists(varRng(i, 1)) Then
objDic.Item(varRng(i, 1)) = objDic.Item(varRng(i, 1)) & "/" & varRng(i, 2)
Else
objDic.Add varRng(i, 1), varRng(i, 2)
End If
Next i
Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
Range("A2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Keys)
Range("B2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Items)
Set objDic = Nothing
End Sub
here's another dictionary approach (no reference adding required)
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long
data = Range("B2", Cells(Rows.Count, 1).End(xlUp)).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(data)
.Item(data(i, 1)) = .Item(data(i, 1)) & "/" & data(i, 2)
Next
Range("A1").CurrentRegion.Resize(Range("A1").CurrentRegion.Rows.Count - 1).Offset(1).ClearContents
i = 1
For Each key In .Keys
i = i + 1
Cells(i, 1) = key
Cells(i, 2) = Mid(.Item(key), 2)
Next
End With
End Sub
BTW, should you ever need to combine strings from more columns, you could use
Option Explicit
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long, iCol As Long
With Range("A1").CurrentRegion
With .Resize(.Rows.Count - 1).Offset(1)
data = .Value
.ClearContents
End With
End With
With CreateObject("Scripting.Dictionary")
For iCol = 2 To UBound(data, 2)
For i = 1 To UBound(data)
.Item(data(i, 1)) = Trim(.Item(data(i, 1)) & " " & data(i, iCol))
Next
Range("A2").Resize(.Count) = Application.Transpose(.Keys)
Range("A2").Resize(.Count).Offset(, iCol - 1) = Application.Transpose(.Items)
.RemoveAll
Next
End With
Range("a1").CurrentRegion.Replace what:=" ", replacement:="/", lookat:=xlPart
End Sub

Do While Loop for SKU numbers

I am trying to automate my SKU numbers. I have 3 columns. The first column has 28, the second has 6 and finally the third has 58.
I want the SKU to have a Trend like so 0{(###)col1}{(##)col2}{(##)col3}0
My Code looks like this
Sub SKU()
Dim x As Long
x = 1
i = 1
j = 1
k = 1
Do While Cells(i, 1) <> ""
Do While Cells(j, 2) <> ""
Do While Cells(k, 3) <> ""
Cells(x, 4).Value = Format(0, "0") & Format(i, "000") & _
Format(j, "00") & Format(k, "00") & Format(0, "0")
k = k + 1
x = x + 1
Loop
j = j + 1
Loop
i = i + 1
Loop
End Sub
No need to use the Do Loop. Find the last row and then use a For loop.
Is this what you are trying?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
'~~> Find last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
If .Cells(i, 1) <> "" And .Cells(i, 2) <> "" And .Cells(i, 3) <> "" Then
'0{(###)col1}{(##)col2}{(##)col3}0
.Cells(i, 4).Value = "'0" & _
Format(.Cells(i, 1), "000") & _
Format(.Cells(i, 2), "00") & _
Format(.Cells(i, 3), "00") & _
"0"
End If
Next i
End With
End Sub
Output for 28,6,58 is 002806580
As i mentioned in the comment to the question, remove first and second do-while loop then replace:
Cells(x, 4).Value = Format(0, "0") & Format(i, "000") & _
Format(j, "00") & Format(k, "00") & Format(0, "0")
with:
Cells(k, 4) = "'" & Format(Cells(k, 1), "000") & _
Format(Cells(k, 2), "00") & Format(Cells(k, 3), "00")
Result: 0280658
In case you want to add leading and ending zeros:
Cells(k, 4) = "'0" & Format(Cells(k, 1), "000") & _
Format(Cells(k, 2), "00") & Format(Cells(k, 3), "00") & "0"
Result: 002806580

Resources