分类汇总结果输出

frankson2017

各位老师：搜索前辈分类汇总代码如下：
有两问点请教，详见附件，谢谢！
1、arr1(i, 1) 的汇总数 如何添加
2、Range("f17").Resize(k, 4) = arr 如何修改指定列（不一定是连续列）输出。

    Dim arr(1 To 10000, 1 To 4), arr1, dic As Object, i As Long, k As Long, hang As Long, Maxrow As Long, t As Single

    Maxrow = Cells(Rows.Count, 1).End(xlUp).Row
    Set dic = CreateObject("scripting.dictionary")
    arr1 = Range("A2:D" & Maxrow)
    For i = 1 To UBound(arr1, 1)
        Mystring = arr1(i, 1) & arr1(i, 2)
        If dic.Exists(Mystring) Then
            hang = dic(Mystring)
            arr(hang, 3) = arr(hang, 3) + arr1(i, 3)
            arr(hang, 4) = arr(hang, 4) + arr1(i, 4)
        Else
            k = k + 1
            dic(Mystring) = k
            arr(k, 1) = arr1(i, 1)
            arr(k, 2) = arr1(i, 2)
            arr(k, 3) = arr1(i, 3)
            arr(k, 4) = arr1(i, 4)
        End If
    Next i
    [F16:M16] = Array("产品名称", "型号", "数量", "金额") '
    Range("f17").Resize(k, 4) = arr

chxw68

使用字典嵌套可以实现。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:d" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 1)) Then
    
11.         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
12.       End If
    
13.       If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
14.         ReDim brr(1 To 3)
    
15.         brr(1) = arr(i, 2)
    
16.       Else
    
17.         brr = d(arr(i, 1))(arr(i, 2))
    
18.       End If
    
19.       brr(2) = brr(2) + arr(i, 3)
    
20.       brr(3) = brr(3) + arr(i, 4)
    
21.       d(arr(i, 1))(arr(i, 2)) = brr
    
22.     Next
    
23.     m = 2
    
24.     For Each aa In d.keys
    
25.       m0 = m
    
26.       sl = 0
    
27.       je = 0
    
28.       For Each bb In d(aa).keys
    
29.         brr = d(aa)(bb)
    
30.         sl = sl + brr(2)
    
31.         je = je + brr(3)
    
32.         .Cells(m, 11).Resize(1, 3) = brr
    
33.         m = m + 1
    
34.       Next
    
35.       .Cells(m0, 6) = aa
    
36.       .Cells(m0, 8) = sl
    
37.       .Cells(m0, 9) = je
    
38.     Next
    
39.   End With
    
40. End Sub
    

复制代码

chxw68

详见附件。

LMY123

同薄，字典嵌套

frankson2017

谢谢  chxw68   楼主，好好学习下。

iwangyi

字典+ADO
Sub CC()
Set d = CreateObject("SCRIPTING.DICTIONARY")
Set d1 = CreateObject("SCRIPTING.DICTIONARY")
Set cn = CreateObject("adodb.connection")
cn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source= " & ThisWorkbook.FullName
arr = Range("A1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 3):d1(arr(i, 1)) = d1(arr(i, 1)) + arr(i, 4)
Next
k = d.keys
For Each xh In k
Sql = "SELECT 产品名称,SUM(数量),SUM(金额) FROM [Sheet1$A1:D] WHERE 型号='" & xh & "' GROUP BY 产品名称"
n = [K65536].End(3).Row + 1
Cells(n, "F") = xh: Cells(n, "H") = d(xh): Cells(n, "i") = d1(xh)
Range("k" & n).CopyFromRecordset cn.Execute(Sql)
Next
End Sub

iwangyi

附近件，字典+AOD I汇总附件

frankson2017

谢谢 7楼 楼主，又学习了一种好方法。