字典常常用来进行求和。
- 单列求和
源数据
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))读取标识行是关键。
结果
