leading zeros using ActiveCell.Offset().value to insert row and value
I am using the following code to insert missing rows of alphanumeric values. While it does work it is removing the leading zeros as shown below...
I have tried playing the the cell formats, with no sucess, Any ideas how to correct this behavior???
Also how can I add the ability to verify the number sequence will start at LxxD159 & LxxM159 respectively, where xx ranges from 1 to 10 (this could get the value from another worksheet.)
L01D001
L01D002
L01D003
L01D159
L01M001
L01M002
L01M3 <----
L01M4 <----
L01M005
Sub test()
Dim val1 As String, txt1 As String, xNum As Long
Dim WorkRows As Long, _
Ndx As Long, _
Diff As Long, _
InsertCounter As Integer, _
WorkColumn As String
WorkColumn = "A" ' <<<<<<< CHANGE TO YOUR COLUMN
WorkRows = Cells(Rows.Count, WorkColumn).End(xlUp).Row
'Starting Len Value
xNum = 5
'Start at the bottom of the list and work up to the top
'that way ndx will always poin to the row just above the ones
'that were inserted
For Ndx = WorkRows To 2 Step -1
Cells(Ndx, WorkColumn).Activate
val1 = Selection.Cells(1).Value
txt1 = Left(val1, xNum - 1)
'establish the rows to insert
val1 = Right(Selection.Cells(1).Value, Len(Selection.Cells(1).Value) - xNum + 1)
Diff = Right(Cells(Ndx, WorkColumn).Value, Len(Cells(Ndx, WorkColumn).Value) - xNum + 1) - Right(Cells(Ndx - 1, WorkColumn).Value, Len(Cells(Ndx - 1, WorkColumn).Value) - xNum + 1)
If Diff 1 Then
For InsertCounter = 1 To Diff - 1
Range(WorkColumn & Ndx).EntireRow.Insert
ActiveCell.Value = txt1 & Right(ActiveCell.Offset(1, 0).Value, Len(ActiveCell.Offset(1, 0).Value) - xNum + 1) - 1
Next InsertCounter
End If
Next Ndx
End Sub
|