Option Explicit
Sub 宏1()
Dim arr, arr1, arr2(1 To 10000, 1 To 1), x&, f&, ff$, i&, j&, m&, n&, s$
f = 5 '编码末尾序号的位数
ff = "00000" '0的个数同 f
x = 0 '生成结果行数
arr1 = Range("a1").CurrentRegion
For i = 1 To UBound(arr1)
arr = Split(arr1(i, 1), "~")
If UBound(arr) = 1 Then
s = Left(arr(0), Len(arr(0)) - f)
m = Right(arr(0), f) '开始序号
n = Right(arr(1), f) '结束序号
For j = m To n
x = x + 1
arr2(x, 1) = s & Format(j, ff)
Next j
End If
Next i
Range("b1").Resize(x, 1) = arr2
End Sub

左边的数据的格式是固定的吗？

简单，10💰🧧搞定

Sub chaifen()
Dim reg As Object, dic As Object, matches As Object
Dim lastrow As Long, i As Long, j As Long
Dim arr
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A1", "A" & lastrow)
Set dic = CreateObject("scripting.dictionary")
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "(\w{8})(\d{5})(?=\W|$)"
For i = 1 To lastrow
Set matches = reg.Execute(arr(i, 1))
If matches.Count > 0 Then
For j = 0 To Val(matches(1).submatches(1) - matches(0).submatches(1) + 1)
If Not dic.exists(matches(0).submatches(1) + j) Then
dic(matches(0).submatches(0) & (matches(0).submatches(1) + j)) = matches(0).submatches(0) & (matches(0).submatches(1) + j)
End If
Next j
End If
Next i
Range("B1", "B" & dic.Count) = Application.Transpose(dic.items)
End Sub

直接拖拽不就行？

不学习，只问的话，还是远离vba

去淘宝求助

Sub Q47436528()
Dim arr, i, s, n, z
#, y#
, d
'绑定字典
Set d = CreateObject("scripting.dictionary")
arr = ActiveSheet.[a1].CurrentRegion
For i = 1 To UBound(arr)
'用~符分割字符串
s = Split(arr(i, 1), "~"): n = 0
'从右往左取对应字符，如果相同，则可判断出循环次数
Do While (Mid(s(0), Len(s(0)) - n, 1) <> Mid(s(1), Len(s(1)) - n, 1))
n = n + 1
If n > Len(s(0)) Then Exit Sub
Loop
'开始循环z至y,并写入字典d
z = CInt(Right(s(0), n)): y = CInt(Right(s(1), n))
For n = z To y
d(Left(s(0), Len(s(0)) - Len(n)) & n) = n
Next n
Next i
'输出结果到C列
If d.Count > 0 Then ActiveSheet.[c1].Resize(d.Count) = Application.Transpose(d.keys)
End Sub