这个能不能用公式做到

PQ中拆分为行，再排序。

内容重排轻松搞定

代码效果

代码：
Sub 单元格拆分()
Dim arr1
Dim x As Integer
With ActiveSheet
For x = .Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If .Cells(x, 1) <> "" Then
arr1 = Split(.Range("a" & x), ",")
If UBound(arr1) >= 1 Then
Rows(x + 1 & ":" & UBound(arr1) + x).Insert Shift:=xlDown '根据拆分出来的数量插入空行
.Range("b" & x).Resize(UBound(arr1) + 1, 1) = Application.Transpose(arr1)
Else
.Range("b" & x) = arr1
End If
End If
Next
End With
End Sub

我也来个
Sub i()
Dim i, ar, br
ar = Range("a1", Cells(Rows.Count, 1).End(3))
s = Join(Application.Transpose(ar), ",")
br = Split(s, ",")
[b1].Resize(UBound(br, 1), 1) = Application.Transpose(br)
End Sub

@硫酸下 :这个应该没问题吧
Set a = CreateObject("vbscript.RegExp")
a.Global = True
a.Pattern = "\d+"
Set d = CreateObject("scripting.Dictionary")
For Each b In Range("a1:a" & [a1].End(xlDown).Row)
For Each c In a.Execute(b)
d(c) = ""
Next c
Next b
[b1].Resize(d.Count) = Application.Transpose(d.Keys)