出个题，学习学习

a园园

要求在附件中，图片也有显示

xlj310

具体还是看数据量的。
如果数据量不大，就直接排序，完成之后就是合并单元格(前三列是合并单元格，第4列是数量相加)，最后删除空行。
如果数据量大，那就用多个字典或者多级字典。

xbox1210

练习练习。

longwin

附件供参考。。。。。。

wanghui834

直接表格函数就可以实现

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. With Sheet1
   
5. arr = .Range("a2").CurrentRegion.Value
   
6. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7. For i = 1 To UBound(arr)
   
8.     s = arr(i, 1): s2 = arr(i, 2): s3 = arr(i, 3)
   
9.     If Not dic.exists(s) Then Set dic(s) = CreateObject("scripting.dictionary")
   
10.     If Not dic(s).exists(s2) Then Set dic(s)(s2) = CreateObject("scripting.dictionary")
    
11.     If Not dic(s)(s2).exists(s3) Then
    
12.         dic(s)(s2)(s3) = arr(i, 4)
    
13.     Else
    
14.         dic(s)(s2)(s3) = dic(s)(s2)(s3) + arr(i, 4)
    
15.     End If
    
16. Next
    
17. For Each k In dic.keys
    
18.     For Each k2 In dic(k).keys
    
19.         For Each k3 In dic(k)(k2).keys
    
20.             m = m + 1
    
21.             brr(m, 1) = k: brr(m, 2) = k2: brr(m, 3) = k3
    
22.             brr(m, 4) = dic(k)(k2)(k3)
    
23.         Next k3
    
24.     Next k2
    
25. Next k
    
26. .[n2:z1000].Clear
    
27. .[n2].Resize(m, 4) = brr
    
28. Application.DisplayAlerts = False
    
29. rw = .Cells(Rows.Count, "n").End(3).Row
    
30. For i = rw To 3 Step -1
    
31.     If .Range("n" & i) = .Range("n" & i - 1) Then
    
32.         Range("n" & i, .Range("n" & i - 1)).Merge
    
33.         Range("r" & i, .Range("r" & i - 1)).Merge
    
34.     End If
    
35.         
    
36.         If .Range("o" & i) = .Range("o" & i - 1) Then
    
37.         Range("o" & i, .Range("o" & i - 1)).Merge
    
38.     End If
    
39. Next
    
40. For i = 2 To rw
    
41.     If .Range("r" & i).MergeCells Then
    
42.         .Range("r" & i).Value = Application.WorksheetFunction.Sum(.Range("Q" & i).Resize(.Range("r" & i).MergeArea.Count))
    
43.     Else
    
44.         .Range("r" & i).Value = .Range("q" & i).Value
    
45.     End If
    
46. Next
    
47. ReDim crr(1 To 1, 1 To 5)
    
48. crr(1, 1) = "合计": crr(1, 4) = Application.Sum(Application.Index(brr, 0, 4))
    
49. .Range("n" & 2 + m).Resize(1, 5) = crr
    
50. .Range("n" & 2 + m).Resize(1, 3).Merge
    
51.     With .Range("n2").CurrentRegion
    
52.         .Borders.LineStyle = 1
    
53.         .HorizontalAlignment = xlCenter
    
54.         .VerticalAlignment = xlCenter
    
55.     End With
    
56. Application.DisplayAlerts = True
    
57. End With
    
58. End Sub
    

复制代码

Qs18

试试...........

Qs18

试试.........

一招秒杀

用个透视表不就轻易解决了吗？