大神们，有点急

@@🌴菠萝蜜🌴 大神在吗，大神

Option Explicit
Sub abc()
　Dim i, j, a, b, t
　a = [a1].CurrentRegion.Resize(, 2).Value
　b = "0.123456789号" '需要保留的都放这框里，小数点也给你保留了
　For i = 2 To UBound(a)
　　For j = 1 To Len(a(i, 2))
　　　If InStr(b, Mid(a(i, 2), j, 1)) Then _
　　　　t = t & Mid(a(i, 2), j, 1)
　　Next
　　a(i, 2) = t: t = vbNullString
　Next
　[i1].Resize(UBound(a), 2) = a
End Sub

Office12版本以上，直接第一个写上数字， cctrl+e,智能填充就把数字全部提取了。自己再批量加个号就可以了

@🌴菠萝蜜🌴 哥看看有问题不

运行了没反应，下面是步骤@🌴菠萝蜜🌴

@霖骆 有没有方法只复制结果，因为我只想要结果，A列要删除的

'黄色区域为源数据，绿色区域为运行后的结果。

'增加了几种规则
Option Explicit
Sub abc()
　Dim i, j, a, b, t, p
　a = [a1].CurrentRegion.Resize(, 2).Value
　b = "0.123456789号"
　For i = 2 To UBound(a)
　　For j = 1 To Len(a(i, 2))
　　　If InStr(b, Mid(a(i, 2), j, 1)) = 0 Then _
　　　Mid(a(i, 2), j, 1) = Space(1)
　　Next
　　t = Split(Replace(a(i, 2), "号", "号 ")): p = -1
　　For j = 0 To UBound(t)
　　　If Len(t(j)) Then
　　　　If InStr(t(j), "号") > 1 Then a(i, 2) = t(j): Exit For
　　　　If IsNumeric(t(j)) And p = -1 Then p = j
　　　End If
　　Next
　　If j = UBound(t) + 1 And p > -1 Then a(i, 2) = t(p)
　Next
　[d1].Resize(UBound(a), 2) = a
End Sub