拆分数据

yshcy

A-D列是数据源，绿色的是想要的结果。从20行开始的内容是自己写的（结果不正确），请老师们指教，谢谢

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    arr = Range("a1").CurrentRegion
    ReDim brr(1 To 1000, 1 To 5)
    For i = 2 To UBound(arr)
        crr = Split(arr(i, 3), "、")
        Set d = CreateObject("scripting.dictionary")
        For k = 0 To UBound(crr)
            d(crr(k)) = ""
        Next
        For Each k In d.keys
            Set dic = CreateObject("scripting.dictionary")
            m = m + 1
            brr(m, 1) = arr(i, 1)
            brr(m, 2) = arr(i, 2)
            brr(m, 5) = arr(i, 4)
            brr(m, 4) = k
            For j = 0 To UBound(crr)
                dic(crr(j)) = ""
            Next
            dic.Remove k
            brr(m, 3) = Join(dic.keys, "、")
        Next k
    Next i
    [g2].Resize(m, UBound(brr, 2)) = brr
    Set d = Nothing
    Set dic = Nothing
    Beep
End Sub

wang-way

taller

taller

1. ' 只使用数组的解决方案（不使用字典）
   
2. Sub test()
   
3.     Const SEP = "、"
   
4.     arr = Range("a1").CurrentRegion
   
5.     ReDim brr(1 To 1000, 1 To 5)
   
6.     ColCnt = UBound(arr, 2)
   
7.     For i = 2 To UBound(arr)
   
8.         crr = Split(arr(i, 3), SEP)
   
9.         For k = 0 To UBound(crr)
   
10.             m = m + 1
    
11.             brr(m, 4) = crr(k)
    
12.             For n = 1 To ColCnt - 2
    
13.                 brr(m, n) = arr(i, n)
    
14.             Next n
    
15.             brr(m, ColCnt + 1) = arr(i, ColCnt)
    
16.             sname = arr(i, ColCnt - 1)
    
17.             If Right(sname, Len(crr(k))) = crr(k) Then
    
18.                 sKey = SEP & crr(k)
    
19.             Else
    
20.                 sKey = crr(k) & SEP
    
21.             End If
    
22.             brr(m, ColCnt - 1) = Replace(sname, sKey, "", , , vbTextCompare)
    
23.         Next k
    
24.     Next i
    
25.     [g20].Resize(m, UBound(brr, 2)) = brr
    
26. End Sub
    
27. 
    

复制代码

今铭昔

ykcbf1100

参与一下。。。

ykcbf1100

1. Sub ykcbf()    '//2025.4.7
   
2.     arr = Range("a1").CurrentRegion
   
3.     ReDim brr(1 To 1000, 1 To 5)
   
4.     For i = 2 To UBound(arr)
   
5.         k = InStr(arr(i, 3), "、")
   
6.         m = m + 1
   
7.         brr(m, 1) = arr(i, 1)
   
8.         brr(m, 2) = arr(i, 2)
   
9.         brr(m, 4) = Left(arr(i, 3), k - 1)
   
10.         brr(m, 3) = Mid(arr(i, 3), k + 1)
    
11.         brr(m, 5) = arr(i, 4)
    
12.     Next i
    
13.     [g2].Resize(m, UBound(brr, 2)) = brr
    
14. End Sub
    

复制代码

limonet

let
    源 = Excel.CurrentWorkbook(){[Name="表1"]}[Content],
    复制列 = Table.DuplicateColumn(源, "所有人员", "陪同人员"),
    拆分列 = Table.ExpandListColumn(Table.TransformColumns(复制列, {"所有人员", Splitter.SplitTextByDelimiter("、", QuoteStyle.Csv)}), "所有人员"),
    深化 = Table.ReplaceValue(拆分列,each [所有人员],"、",(x,y,z)=>Text.Combine(List.RemoveItems(Text.Split(x,z),{y}),z),{"陪同人员"})
in
    深化