求助大神：关于数据整理

dylanleelee

原始数据如表格左侧所示，希望整理成右侧的样子。

是否可以一键搞定，或者公式？
希望各位大神不吝赐教

taller

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

shadow792

1. =SORT(HSTACK(TEXTSPLIT(TEXTJOIN("、",,B2:B5),,"、"),DROP(REDUCE("",A2:A5,LAMBDA(x,y,VSTACK(x,EXPAND(y,COUNTA(TEXTSPLIT(OFFSET(y,,1),"、")),,y)))),1)),1)

复制代码

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, cr, i&, j&, r&
   
    Application.ScreenUpdating = False
   
    ar = [a1].CurrentRegion.Value
    ReDim br(1 To UBound(ar) * 10, 1 To 3)
    For i = 2 To UBound(ar)
        cr = Split(ar(i, 2), "、")
        For j = 0 To UBound(cr)
            r = r + 1
            br(r, 1) = cr(j)
            br(r, 2) = ar(i, 1)
            br(r, 3) = Val(cr(j))
        Next j
    Next i
        
    bSort br, 1, r, 1, UBound(br, 2), 3
    [I2].Resize(r, 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

。。。。。。。。。。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr(1 To 1000, 1 To 2)
   
4.     With Worksheets("sheet1")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("a2:b" & r)
   
7.         m = 0
   
8.         For i = 1 To UBound(arr)
   
9.             xm = Split(arr(i, 2), "、")
   
10.             For j = 0 To UBound(xm)
    
11.                 m = m + 1
    
12.                 brr(m, 1) = xm(j)
    
13.                 brr(m, 2) = arr(i, 1)
    
14.             Next
    
15.         Next
    
16.         If m > 0 Then
    
17.             .Range("h2").Resize(m, UBound(brr, 2)) = brr
    
18.             .Range("h2").Resize(m, UBound(brr, 2)).Sort key1:=.Range("h2"), order1:=xlAscending, Header:=xlNo
    
19.         End If
    
20.     End With
    
21. End Sub
    

复制代码

chxw68

练习。。。

zxsea_7426

继续凑个热闹：