42、[VBA入门到放弃笔记]字典应用：求和

字典常常用来进行求和。

• 单列求和

源数据

Sub 求和()
    Dim arr, i As Long, d As Object
    arr = [a1].CurrentRegion'数组赋值
    Set d = CreateObject("scripting.dictionary")'创建字典
    For i = 2 To UBound(arr)'遍历数组
        d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)'对部门进行求和
    Next
    [d2].Resize(d.Count, 1) = Application.Transpose(d.keys)'输出数据
    [e2].Resize(d.Count, 1) = Application.Transpose(d.items)
End Sub

结果

---

• 单条件多列求和

源数据

• 要实现这样的求和，需要用字典来标记行。
• 用exists判断部门是否存在，当遍历部门时，部门第一次出现的时候，是肯定不存在字典里的，因此，对部门进行计数，然后放进字典，标识行。以例子为参考......
• 1、当 i=2时，A不存在，则计数 k=k+1，k=1，d(A)=1，将部门A放在数组第一行。
• 2 当 i=3时，B不存在，则计数 k=k+1，k=2，d(B)=2，将部门B放在数组第二行。
• 3、当 i=4时，C不存在，则计数 k=k+1，k=3，d(C)=2，将部门C放在数组第三行。
  ......
• 4、当 i=10时，E不存在，则计数 k=k+1，k=5，d(E)=5,将部门E放在数组第五行。
  -----依次类推--------

• 假定下图绿色区域是一个数组，用来存放数据。

  
  
  

  Paste_Image.png

Sub 求和()
    Dim arr, i As Long, d As Object
    arr = [a1].CurrentRegion '数据放进数组arr
    '定义一个和arr一样大小的数组brr来存放求和数据
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    Set d = CreateObject("scripting.dictionary") '创建字典
    For i = 2 To UBound(arr) '遍历数组
        '如果部门没有添加到字典里（第一次肯定不会存在字典里）
        If Not d.exists(arr(i, 1)) Then
            k = k + 1 '计数
            d(arr(i, 1)) = k '字典标识行，存入字典
            For j = 1 To UBound(arr, 2) '将第一条数据，从arr放进brr
                brr(k, j) = arr(i, j)
            Next
        Else '如果部门已经在字典里面了
            m = d(arr(i, 1)) '读取字典标识的行,如A,m=1，B,m=2.......
            brr(m, 2) = brr(m, 2) + arr(i, 2) '数据累加，字段1
            brr(m, 3) = brr(m, 3) + arr(i, 3)'字段2
            brr(m, 4) = brr(m, 4) + arr(i, 4)'字段3
        End If
    Next
    [g2].Resize(k, 4) = brr
End Sub

• 要弄明白上面的代码else后面的累加，先看下面的例子

例子

• 数组arr，arr(2,2)元素，是第二行第二列的位置，当执行代码arr(2, 2) = arr(2, 2) + 10000，arr(2,2)就由原来的200，变成了10200.
  上面的代码就是通过用字典来标识行，实现在数组元素原来的基础上累加。 m = d(arr(i, 1))读取标识行是关键。

结果

---