求助，想用宏实现一维数据转二维格式

deadzlq

PQ参考解法(久违的基操)

saghj

sxbjzjf110

修改了一下代码

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion.Value
   
5. ReDim brr(1 To UBound(arr), 1 To 200)
   
6. rw = 2: cl = 2: sm = 0
   
7. For i = 2 To UBound(arr)
   
8.     s = arr(i, 1) & arr(i, 2)
   
9.     If Not dic.exists(s) Then
   
10.         rw = rw + 1
    
11.         dic(s) = rw
    
12.         brr(rw, 1) = arr(i, 1)
    
13.         brr(rw, 2) = arr(i, 2)
    
14.     End If
    
15.     s2 = arr(i, 3) & arr(i, 4)
    
16.     If Not dic.exists(s2) Then
    
17.         cl = cl + 1
    
18.         dic(s2) = cl
    
19.         brr(1, cl) = arr(i, 3): brr(2, cl) = arr(i, 4)
    
20.     End If
    
21.     s3 = s & s2
    
22.     If Not dic.exists(s3) Then
    
23.         dic(s3) = arr(i, 5)
    
24.         sm = sm + arr(i, 5)
    
25.     Else
    
26.         dic(s3) = dic(s3) = arr(i, 5)
    
27.         sm = sm + arr(i, 5)
    
28.     End If
    
29. Next i
    
30. k = dic.keys
    
31. iit = dic.items
    
32.     For i = 3 To rw
    
33.         s4 = ""
    
34.         s4 = brr(i, 1) & brr(i, 2)
    
35.         For j = 3 To cl
    
36.             s5 = s4 & brr(1, j) & brr(2, j)
    
37.             brr(i, j) = dic(s5)
    
38.         Next
    
39.     Next
    
40. brr(1, 1) = "产品代码": brr(1, 2) = "产品"
    
41. With Sheet2
    
42. .Cells.Clear
    
43. .Range("a1").Resize(rw, cl) = brr
    
44. .Range("a1").Resize(rw, cl).Borders.LineStyle = 1
    
45. .Range("a1").Resize(rw, cl).HorizontalAlignment = xlCenter
    
46. .Range("a1:a2").Merge: .Range("b1:b2").Merge
    
47. .Cells(rw + 2, cl).Value = sm
    
48. End With
    
49. Set dic = Nothing
    
50. End Sub
    

复制代码

Qs18

试试........

Qs18

试试.........

一执成念

把优秀代码改造下