Alan, no I'm not getting notifications of responses…
This one tries to preserve the leading zeroes (even if there are more than one) being guided by the length of the string directly before the hyphen:
Code:
Sub blah()
Dim Results(), Destn As Range, rngSce As Range, Sce, j, Count, SceRw, a, itm, b, Padding, i, Cde, k
Set Destn = Sheets("New").Range("A1") 'top left cell of where the results will go.
Set rngSce = Sheets("Old").Range("A1").CurrentRegion
Sce = rngSce.Value
For j = 1 To 2 '2 loops, first time to get a count of rows needed, second time to populate array
Count = 1
For SceRw = 2 To UBound(Sce)
a = Split(Application.Trim(Sce(SceRw, 3)), ";")
For Each itm In a
b = Split(Application.Trim(itm), "-")
If UBound(b) > 0 Then 'there's a hyphen:
Padding = Len(Application.Trim(b(0)))
For i = CLng(b(0)) To CLng(b(1))
Count = Count + 1
If j > 1 Then
Cde = Format(i, Application.Rept(0, Padding))
For k = 1 To UBound(Sce, 2)
Results(Count, k) = Sce(SceRw, k)
Next k
Results(Count, 3) = Cde
End If
Next i
Else 'there's no hyphen:
Count = Count + 1
If j > 1 Then
Cde = Application.Trim(b(0))
For k = 1 To UBound(Sce, 2)
Results(Count, k) = Sce(SceRw, k)
Next k
Results(Count, 3) = Cde
End If
End If
Next itm
Next SceRw
If j = 1 Then 'create new array
ReDim Results(1 To Count, 1 To UBound(Sce, 2))
For k = 1 To UBound(Sce, 2) 'populate top row of headers:
Results(1, k) = Sce(1, k)
Next k
End If
Next j
Destn.Resize(UBound(Results)).Offset(, 2).NumberFormat = "@" 'format 3rd column as Text
Destn.Resize(UBound(Results), UBound(Results, 2)).Value = Results
End Sub
Bookmarks