哪位高手帮助下，最终实现“表2”的效果？

Qs18

试试...........

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br(), cr, i&, j&, r&
   
    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    For i = 1 To UBound(ar)
        cr = Split(ar(i, 2), "、")
        For j = 0 To UBound(cr)
            r = r + 1
            ReDim Preserve br(1 To 2, 1 To r)
            br(1, r) = cr(j): br(2, r) = ar(i, 1)
        Next j
    Next i
        
    br = Application.Transpose(br)
    bSort br, 1, UBound(br), 1, 2, 1
    [H2].Resize(UBound(br), 2) = br
   
    Application.ScreenUpdating = True
    Beep
End Sub
Function bSort(ByRef ar, ByVal iFirst&, ByVal iLast&, ByVal iLeft&, _
    ByVal iRight&, ByVal iKey&, Optional isOrder As Boolean = True)
    Dim i&, j&, k&, vTemp
   
    For i = iFirst To iLast - 1
        For j = iFirst To iLast + iFirst - 1 - i
            If ar(j, iKey) <> ar(j + 1, iKey) Then
                If ar(j, iKey) < ar(j + 1, iKey) Xor isOrder Then
                    For k = iLeft To iRight
                        vTemp = ar(j, k)
                        ar(j, k) = ar(j + 1, k)
                        ar(j + 1, k) = vTemp
                    Next
                End If
            End If
        Next j
    Next i
End Function

gwjkkkkk

参与一下。。。

cai2532

留下脚印学习了

yanglinzi

yanglinzi

参与一下。。。