Sub Macro1()
i = Range("A65536").End(xlUp).Row
Set m = Range("B65536").End(xlUp)
ReDim arr(1 To (i - m.Row), 1 To 1)
k = Left(m.Value, 4)
a = Mid(m.Value, 5, Len(m.Value) - 5)
L = Len(a)
a = a + 1
For j = 1 To i - m.Row
    n = n + 1
    If n > 3 Then
        n = 1
        a = a + 1
    End If
    If Len(a) < L Then
        For x = 1 To L - Len(a)
            a = "0" & a
        Next
    End If
    arr(j, 1) = k & a & n
Next
m.Offset(1, 0).Resize(j - 1, 1) = arr
End Sub