条件字典数组求和后再汇总，难！咋实现？？？

wowo000

星期天了，打搅论坛里的老师休息，俺有个难题：想实现附件里的要求，恳请哪位帮忙，多谢！！！！！！！！！

microyip

字典(关键字)=字典(关键字)+数据
就是去重汇总了

wowo000

尊敬的microyip老师：俺就卡在这里了，劳烦帮弄弄？？谢谢！！！

蓝桥玄霜

求和的例子：

taller

多循环两次行列求和就可以了

3190496160

Sub 求和()
    Set d = CreateObject("scripting.dictionary")
    arr = Range("A1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) + 1)
    k = 1
    For i = 2 To UBound(arr)
        If Trim(arr(i, 1)) <> "" Then
            t = d(Trim(arr(i, 1)))
            If t = "" Then
                k = k + 1
                d(Trim(arr(i, 1))) = k
                t = k
                brr(k, 1) = arr(i, 1)
            End If
            For j = 2 To UBound(arr, 2)
                brr(t, j) = brr(t, j) + arr(i, j)
                brr(t, UBound(brr, 2)) = brr(t, UBound(brr, 2)) + arr(i, j)
            Next j
        End If
    Next i
    For j = 2 To UBound(brr, 2)
        brr(k + 1, j) = Application.Sum(Application.Index(brr, 0, j))
    Next j
    For j = 1 To UBound(arr, 2)
        brr(1, j) = arr(1, j)
    Next j
    brr(k + 1, 1) = "合计"
    brr(1, UBound(brr, 2)) = "合计"
    Range("K1:IV65536").ClearContents
    With Range("K1")
        .Resize(k + 1, UBound(brr, 2)) = brr
    End With
    Set d = Nothing
End Sub

wowo000

谢谢两位版主老师的解答！！谢谢！！！

donghui2363

练习练习

1. Sub 汇总()
   
2. Set d = CreateObject("scripting.dictionary")
   
3.     With Sheets("单条件")
   
4.         r = .Range("a65536").End(xlUp).Row
   
5.         arr = .Range("a2:i" & r)
   
6.         ReDim brr(1 To UBound(arr), 1 To 10)
   
7.         For i = 1 To UBound(arr)
   
8.             If arr(i, 1) = "" Then Exit For
   
9.             s = arr(i, 1)
   
10.             If Not d.exists(s) Then d(s) = d.Count + 1
    
11.             brr(d(s), 1) = s
    
12.             For j = 2 To UBound(arr, 2)
    
13.                 brr(d(s), j) = brr(d(s), j) + arr(i, j)
    
14.             Next j
    
15.         Next i
    
16.         For i = 1 To d.Count
    
17.             For j = 2 To UBound(brr, 2) - 1
    
18.                 brr(i, UBound(brr, 2)) = brr(i, UBound(brr, 2)) + brr(i, j)
    
19.                 brr(d.Count + 1, j) = brr(d.Count + 1, j) + brr(i, j)
    
20.             Next j
    
21.                 brr(d.Count + 1, 10) = brr(d.Count + 1, 10) + brr(i, 10)
    
22.         Next i
    
23.         .Range("k2").Resize(d.Count + 1, 10) = brr
    
24.     End With
    
25. End Sub

复制代码

bajifeng

>>>>>>>>>>

bajifeng

1. Sub ba() 'by bajifeng | QQ：249346223
   
2. Dim br(1 To 10000, 1 To 10)
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. ar = Range("a1:i" & [a65536].End(3).Row)
   
5. For i = 2 To UBound(ar)
   
6.     If Len(ar(i, 1)) And Not d.exists(ar(i, 1)) Then
   
7.         n = n + 1
   
8.         d(ar(i, 1)) = n
   
9.         For j = 1 To 9
   
10.             br(n, j) = ar(i, j)
    
11.         Next
    
12.     Else
    
13.         For j = 2 To 9
    
14.             ib = d(ar(i, 1))
    
15.             br(ib, j) = br(ib, j) + ar(i, j)
    
16.         Next
    
17.     End If
    
18. Next
    
19. For i = 1 To n
    
20.     s = 0
    
21.     For j = 2 To 9
    
22.         s = s + br(i, j)
    
23.     Next
    
24.     br(i, 10) = s
    
25. Next
    
26. For j = 2 To 10
    
27.     s = 0
    
28.     For i = 1 To n
    
29.         s = s + br(i, j)
    
30.     Next
    
31.     br(n + 1, j) = s
    
32. Next
    
33. [t1] = "合计"
    
34. br(n + 1, 1) = [t1]
    
35. [k2].Resize(999, 10).Clear
    
36. [k2].Resize(n + 1, 10) = br
    
37. End Sub
    

复制代码