求助大神帮帮忙,数据分裂转换

ykcbf1100

代码供参考。。。

1. Sub ykcbf()   '//2024.2.16
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     Set reg = CreateObject("VBScript.RegExp")
   
5.     Set List = CreateObject("System.Collections.ArrayList")
   
6.     r = Me.Cells(Rows.Count, 1).End(3).Row
   
7.     arr = Me.Range("a1:b" & r)
   
8.     ReDim brr(1 To 1000, 1 To 20)
   
9.     With reg
   
10.         .Global = True
    
11.         .Pattern = "([a-zA-Z]+\d+)|(\d+)|([\u4e00-\u9fa5]+)"
    
12.     End With
    
13.     For i = 2 To UBound(arr)
    
14.         st = arr(i, 1)
    
15.         Set mh = reg.Execute(st)
    
16.         s = mh(0).Value & "|" & mh(1).Value
    
17.         d1(s) = ""
    
18.         ss = s & "|" & mh(2).Value
    
19.         d(ss) = d(ss) + arr(i, 2)
    
20.         s2 = mh(2).Value
    
21.         If Not List.Contains(s2) Then List.Add s2
    
22.     Next
    
23.     List.Sort
    
24.     For Each k In d1.keys
    
25.         m = m + 1
    
26.         brr(m, 1) = Split(k, "|")(0)
    
27.         brr(m, 2) = Split(k, "|")(1)
    
28.     Next
    
29.     With Sheets("Sheet2")
    
30.         .UsedRange.Offset(2).Clear
    
31.         .[c2:z2].Clear
    
32.         .[c1:z1].UnMerge
    
33.         .Columns(1).NumberFormatLocal = "@"
    
34.         .[c2].Resize(1, List.Count) = List.toArray
    
35.         .[a3].Resize(m, 2) = brr
    
36.         .[c1].Resize(1, List.Count).Merge
    
37.         .UsedRange.Borders.LineStyle = 1
    
38.         arr = .UsedRange
    
39.         For i = 3 To UBound(arr)
    
40.             For j = 3 To List.Count + 2
    
41.                 s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(2, j)
    
42.                 If d.exists(s) Then
    
43.                     arr(i, j) = d(s)
    
44.                 End If
    
45.             Next
    
46.         Next
    
47.         .UsedRange = arr
    
48.     End With
    
49.     Set d = Nothing
    
50.     MsgBox "OK!"
    
51. End Sub
    

复制代码

明天会更好zj

提问题，最好是接近自己真实的数据，并且包含所有可能的情形，不是随随便便模拟些数据，和实际数据相差万里，老师也只是根据你模拟的数据规律来写代码，不要一而再再而三的提成要求，浪费老师的时间。

豪情雲天

ykcbf1100 发表于 2024-2-16 08:41
代码供参考。。。

非常感谢大佬的耐心帮助