Sub b0() [b2:b10000].ClearContents For i = 2 To 10000 s1 = CStr(Cells(i, "A")) If s1 = "" Then Exit For L1 = Len(s1) For j = 1 To L1 If Asc(Mid(s1, j + 1, 1)) <= Asc("9") And Asc(Mid(s1, j + 1, 1)) >= Asc("0") Then Exit For Next j s2 = "" For k = 1 To 6 - L1 s2 = s2 & "0" Next k s3 = Left(s1, j) & s2 & Right(s1, L1 - j) Cells(i, "B") = s3 Next i End Sub