套用别人代码 不可以运行 请高手帮忙看下错在哪了

piena

Sub test()

Dim d As Object, a, b, j%, w!    '定义参数
Dim ss$, n%, x                      '定义参数
ActiveSheet.UsedRange.Offset(2, 0) = ""    '清空第2行以下的单元格。
a = Sheet1.Range(Sheet1.[a2], Sheet1.[i65536].End(xlUp))   '把原始数据所在的表1自A4以下的I列最后的非空单元格区域的值赋给变量a。
Set d = CreateObject("scripting.dictionary")      '创建字典对象d。
ReDim b(1 To UBound(a), 1 To 8)
For i = 1 To UBound(a)                    '在1 和数组a第一维的上界值之间逐一循环
ss = a(i, 2) & a(i, 3) & a(i, 4) & a(i, 5) & a(i, 6) & a(i, 1)   '把不变的内容连起来然后赋给变量ss。
If Not d.Exists(ss) Then      '如果字典d里面不存在ss表示的关键字，那么执行下面的语句。
n = n + 1               '把变量n增加1以后仍然赋给n
d.Add ss, n             '把ss的值作为关键字，n的值作为对应的项一起加入字典d中。n的值实际是关键字的位置次序，如n=1时是第一个关键字；n=2时是第二个关键字。
b(n, 1) = a(i, 2): b(n, 2) = a(i, 3): b(n, 3) = a(i, 4): b(n, 5) = a(i, 4)   '4个语句分别给数组b的各个元素赋以对应的值
b(n, 5) = a(i, 6): b(n, 6) = a(i, 1): b(n, 7) = a(i, 7)     
Else
b(d(ss), 7) = b(d(ss), 7) & "+" & a(i, 7)   
End If
Next
For i = 1 To d.Count     '在字典关键字数目中逐一循环
x = Split(b(i, 7), "+")   '运用VBA函数Split把b(i, 7)按照"+"分割，返回一个下标从零开始的一维数组x。
For j = 0 To UBound(x)    '在上面的x数组之间逐一循环
w = w + x(j)              '把变量w加x(j)数组的一个元素以后仍然赋给w。实际得到x数组的累加值。
Next j
b(i, 8) = b(i, 5) * b(i, 7)    'w求出后经过按要求计算得到的值赋给数组b的第8列元素就是数量和单价的乘积。（数量列）另一句把变量w置0。避免在新一次的循环中误加进去。
Next
[b4].Resize(n, 8) = b     '最后把数组b赋给B4开始的单元格区域。

End Sub


目的是想实现把表1中的数据按照相等的求和以后放在表2中  代码是套用蓝桥版主的  就是不可以运行

蓝桥玄霜

这不是我的代码哦。
代码要放在模块里面。

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Brr, x$, j&, aa
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Application.DisplayAlerts = False
   
6. Sheet2.Activate
   
7. [a3:h5000].ClearContents
   
8. [a3:h5000].Borders.LineStyle = xlNone
   
9. Arr = Sheet1.[a1].CurrentRegion
   
10. For i = 2 To UBound(Arr)
    
11.     x = Arr(i, 2) & "," & Arr(i, 3) & "," & Arr(i, 4) & "," & Arr(i, 5) & "," & Arr(i, 6) & "," & Arr(i, 1)
    
12.     d(x) = d(x) & i & ","
    
13. Next
    
14. k = d.keys: t = d.items
    
15. [a3].Resize(d.Count) = Application.Transpose(k)
    
16. [a3].Resize(d.Count).TextToColumns Comma:=True
    
17. ReDim Brr(1 To d.Count, 1 To 2)
    
18. For i = 0 To UBound(k)
    
19.     t(i) = Left(t(i), Len(t(i)) - 1)
    
20.     If InStr(t(i), ",") Then
    
21.         aa = Split(t(i), ",")
    
22.         For j = 0 To UBound(aa)
    
23.             Brr(i + 1, 1) = Brr(i + 1, 1) + Arr(aa(j), 7)
    
24.             Brr(i + 1, 2) = Brr(i + 1, 2) + Arr(aa(j), 8)
    
25.         Next
    
26.     Else
    
27.         Brr(i + 1, 1) = Arr(t(i), 7)
    
28.         Brr(i + 1, 2) = Arr(t(i), 8)
    
29.     End If
    
30. Next
    
31. [g3].Resize(UBound(Brr), 2) = Brr
    
32. [a2].CurrentRegion.Borders.LineStyle = 1
    
33. Application.DisplayAlerts = True
    
34. End Sub
    

复制代码

蓝桥玄霜

请见附件。

LMY123

字典多条件多列分类汇总,d(x) = d(x) & i & ","