Sub sd()
Dim arr1()
Dim i As Long, k As Long, z As Long, b As Long, x1 As Long, x2 As Long, y1 As Long
lr = Cells(Rows.Count, 2).End(xlUp).Row
Columns(4).Clear
For z = 2 To lr
    a = 9
    b = Len(Cells(z, 2)) - a
    x1 = Right(Cells(z, 2), a)
    x2 = Right(Cells(z, 3), a)
    y1 = Left(Cells(z, 3), b)
k = x2 - x1
ReDim arr1(k)
x = 0
For i = LBound(arr1) To UBound(arr1)
    arr1(i) = y1 & x1 + x
    x = x + 1
Next i
    lr2 = Cells(Rows.Count, 4).End(xlUp).Row + 1
    If lr2 = 2 Then lr2 = 1
        Range("D" & lr2 & ":D" & lr2 + k).NumberFormat = "@"
        Range("D" & lr2 & ":D" & lr2 + k).Value = Application.WorksheetFunction.Transpose(arr1)
    Erase arr1
Next z
End Sub