单列数据按新标准重新分配至多列

ynzsvt

用品名的字典指向类进行处理，结果需按品名排序。
模块：

1. Sub 一维转二维()
   
2. '用品名的字典Dic指向类PnMnz()
   
3. 'hh还未使用的行号
   
4. 'h正在使用的行号
   
5. Dim PnMnz() As PnMn, Dic As Object
   
6. Dim Hh&, H&, i&, j&, k&, N&, Brr, Arr, Rng As Range
   
7. Arr = [A1].CurrentRegion
   
8. 
   
9. Hh = 1: N = UBound(Arr)
   
10. ReDim Brr(1 To N, 1 To 5)
    
11. ReDim PnMnz(1 To N)
    
12. Set Dic = CreateObject("Scripting.Dictionary")
    
13. 
    
14. For j = 2 To UBound(Arr)
    
15.   i = InStr(1, "abcd", Left(Arr(j, 2), 1))
    
16.   If Not Dic.exists(Arr(j, 1)) Then
    
17.    Dic(Arr(j, 1)) = Dic.Count + 1
    
18.    k = Dic(Arr(j, 1))
    
19.    Set PnMnz(k) = New PnMn
    
20.    Call PnMnz(k).Init(N)
    
21.    Call PnMnz(k).Add(i, Hh, H)
    
22.    Brr(H, 1) = Arr(j, 1): Brr(H, i + 1) = Arr(j, 2)
    
23.   Else
    
24.    k = Dic(Arr(j, 1))
    
25.    Call PnMnz(k).Add(i, Hh, H)
    
26.    Brr(H, 1) = Arr(j, 1): Brr(H, i + 1) = Arr(j, 2)
    
27.   End If
    
28. Next j
    
29. 
    
30. [H2].Resize(Hh - 1, 5) = Brr
    
31. Set Dic = Nothing
    
32. End Sub

复制代码

类PnMn

1. Dim Arr '指向行号
   
2. Dim Brr(1 To 4) '指向Arr
   
3. 
   
4. Sub Init(N&)
   
5. ReDim Arr(0 To N)
   
6. End Sub
   
7. 
   
8. Sub Add(i&, ByRef Hh&, ByRef H&)
   
9. Dim j&
   
10. j = Brr(i): Brr(i) = Brr(i) + 1
    
11. If Arr(j) = 0 Then Arr(j) = Hh: Hh = Hh + 1
    
12. H = Arr(j)
    
13. End Sub
    

复制代码

usedrange

15303194321 发表于 2024-6-20 10:23
十分顺畅。  谢谢。追加一下 ，品名那一列怎么合并同类项呢？

试试这个

1. Sub t2()
   
2.     Dim dic, m%, arr, brr, r%, c1%, c2%, c3%, c4%, b, i%, til
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     With Sheets("原数据")
   
5.         m = .[a3].End(4).Row
   
6.         ss = .Range("a2:b" & m).Sort(key1:="品名", key2:="型号", Header:=xlYes)
   
7.         arr = .Range("a3:b" & m)
   
8.     End With
   
9.     til = Array("品名", "区域A", "区域B", "区域C", "区域D")
   
10.     For i = 1 To UBound(arr)
    
11.         dic(arr(i, 1)) = dic(arr(i, 1)) & "|" & arr(i, 2)
    
12.     Next i
    
13.     ReDim brr(1 To 100, 1 To 5)
    
14.     r = 2
    
15.     For Each k In dic.keys
    
16.         brr(r, 1) = k
    
17.         b = Split(dic(k), "|")
    
18.         c1 = 0: c2 = 0: c3 = 0: c4 = 0
    
19.         brr(r, 1) = k
    
20.         For i = 1 To UBound(b)
    
21.             If r - 1 = 1 Then brr(r - 1, i) = til(i - 1)
    
22.             If InStr(b(i), "a") Then
    
23.                 brr(r, 1) = k
    
24.                 brr(r, 2) = brr(r, 2) + b(i) + "  "
    
25.             ElseIf InStr(b(i), "b") Then
    
26.                 brr(r, 1) = k
    
27.                 brr(r, 3) = brr(r, 3) + b(i) + "  "
    
28.             ElseIf InStr(b(i), "c") Then
    
29.                 brr(r, 1) = k
    
30.                 brr(r, 4) = brr(r, 4) + b(i) + "  "
    
31.             ElseIf InStr(b(i), "d") Then
    
32.                 brr(r, 1) = k
    
33.                 brr(r, 5) = brr(r, 5) + b(i) + "  "
    
34.             End If
    
35.         Next i
    
36.         r = r + 1
    
37.     Next k
    
38.     Sheets("目标表样").[g2].Resize(UBound(brr), 5) = brr
    
39. End Sub
    

复制代码

15303194321

usedrange 发表于 2024-6-20 17:11
试试这个

谢谢  等我试试再回复

ynzsvt

要求高了还得是类处理