解决拆分编号

qiurongzhuang88

请大师们帮忙解决，谢谢！

jiangxiaoyun

powerquery拆分别，很好用

Jason_WangSS

不懂，看看大神怎么解

约定的童话

之前有个大师用函数解决了啊http://club.excelhome.net/thread-1505190-1-1.html

everbest2015

Sub MySplit()
        Dim sh As Worksheet, ar, i&, r&, n&, m&, mm&, nn&, j&, s$
        Dim br(), tt, t, brr
        ThisWorkbook.Activate
        Set sh = Sheet1
        With sh
                r = .Cells(.Rows.Count, "a").End(xlUp).Row
                If r < 2 Then Exit Sub
                ar = .Range("a1").Resize(r, 10)
                ReDim br(1 To 10000, 1 To 10)
                For i = 3 To UBound(ar)
                        s = StrConv(ar(i, 3), vbNarrow)
                        If s <> "" Then
                                tt = Split(s, ",")
                                For Each t In tt
                                      brr = Split(t, "~")
                                        If InStr(t, "~") Then
                                              nn = Val(Mid(brr(1), 2)) - Val(Mid(brr(0), 2)) + 1
                                        Else
                                              nn = 1
                                        End If
                                        For j = 1 To nn
                                              n = n + 1
                                              br(n, 1) = ar(i, 1)
                                              br(n, 2) = ar(i, 2)
                                              If Mid(brr(0), 2) = "1" Then
                                                    br(n, 3) = Left(brr(0), 1) & j
                                                Else
                                                    mm = mm + 1
                                                        If mm = 1 Then
                                                            m = Val(Mid(brr(0), 2))
                                                        Else
                                                            m = m + 1
                                                         End If
                                                        br(n, 3) = Left(brr(0), 1) & m
                                              End If
                                              br(n, 4) = ar(i, 4)
                                              br(n, 5) = ar(i, 5)
                                              br(n, 6) = ar(i, 6)
                                              br(n, 7) = 1
                                              br(n, 8) = ar(i, 8)
                                              br(n, 9) = ar(i, 9)
                                              br(n, 10) = ar(i, 10)
                                        Next
                                        mm = 0
                                Next
                        End If
                Next
                If nn = 0 Then Exit Sub
                Set sh = Sheet2
                With sh
                        .UsedRange.Offset(2).ClearContents
                        .Range("a3").Resize(n, 10) = br
                        .UsedRange.HorizontalAlignment = xlCenter
                        .UsedRange.VerticalAlignment = xlCenter
                End With
        End With
End Sub

everbest2015

代码在审核  先上个图片。 仅供参考

QuantumChou

everbest2015 发表于 2019-10-28 14:40
代码在审核  先上个图片。 仅供参考

大神，这是什么软件写的代码，怎么这么好看

everbest2015

QuantumChou 发表于 2019-10-28 15:00
大神，这是什么软件写的代码，怎么这么好看

sublime text3

月关

'本来只想划拉两下，划拉划拉就划拉完了，那就发上来吧

Sub test()
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "\d+"
arr = Sheets("原表").[a1].CurrentRegion
ReDim brr(1 To 10, 1 To 1)
For i = 3 To UBound(arr)
x = Split(Replace(arr(i, 3), "，", ","), ",")
    For ii = 0 To UBound(x)
        Set y = .Execute(x(ii))
        If y.Count > 1 Then
            s = Mid(.Replace(x(ii), ""), InStrRev(.Replace(x(ii), ""), "~") + 1)
            For k = y(0) To y(1)
                n = n + 1: ReDim Preserve brr(1 To 10, 1 To n)
                brr(1, n) = arr(i, 1): brr(2, n) = arr(i, 2)
                brr(3, n) = s & k
                brr(4, n) = arr(i, 4): brr(5, n) = arr(i, 5): brr(6, n) = arr(i, 6): brr(7, n) = 1
                brr(8, n) = brr(5, n) * brr(6, n) / 1000000
                brr(9, n) = arr(i, 9): brr(10, n) = arr(i, 10)
            Next
        Else
            s = .Replace(x(ii), "")
            n = n + 1: ReDim Preserve brr(1 To 10, 1 To n)
                For m = 1 To 10
                    brr(m, n) = arr(i, m)
                Next
            brr(3, n) = s & y(0): brr(8, n) = arr(i, 5) * arr(i, 6) / 1000000
        End If
    Next
Next
End With
Sheets.Add
Sheets("原表").[a1:j2].Copy
ActiveSheet.Paste
[a3].Resize(UBound(brr, 2), 10) = Application.Transpose(brr)
End Sub

everbest2015

约定的童话 发表于 2019-10-28 13:30
之前有个大师用函数解决了啊http://club.excelhome.net/thread-1505190-1-1.html

为何不开源