36、VBA常用小代码304:一个字典实现条件求和和计数功能

记忆里那海

记忆里那海

2021-04-08

有朋友(就是上次所说的貌美如如花的那位)说我们可以玩个点播台,每期插播一首音乐。额米豆腐,贫……在下也觉得甚好啊……那先来一首寂寞沙洲冷吧~

上期我们留了一道练手题(点击阅读原文可以下载示例文件),如下图所示,根据A:B列的数据,计算D列人员的考试次数和考试成绩。

这是VBA编程经常需要处理的也是工作中常见的问题:条件计数(考试次数)和条件求和(考试成绩)。

那么——可能有的小伙伴代码是这么写的:


Sub Dicttl1()

Dim d As Object, arr, brr, i&

Set d = CreateObject("scripting.dictionary")

"后期字典

"d.CompareMode = vbTextCompare

"不区分字母大小写

arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)

"数据源装入数组arr

For i = 1 To UBound(arr)

"遍历数据源,累加姓名成绩

d(arr(i, 1)) = d(arr(i, 1)) Val(arr(i, 2))

"val函数提取纯数值,如果是纯文本值则计算为0,避免文本值数学运算出错

"如果是重复值计数,可以改成如下:

"d(arr(i, 1)) = d(arr(i, 1)) 1

Next

brr = Range("d1:f" & Cells(Rows.Count, 4).End(xlUp).Row)

"查询区域装入数组brr

For i = 2 To UBound(brr)

If d.exists(brr(i, 1)) Then

"如果字典中存在查询的姓名,则提取总成绩

brr(i, 3) = d(brr(i, 1))

Else

"否则返回空文本""

brr(i, 3) = ""

End If

Next

With Range("d1:f" & Cells(Rows.Count, 4).End(xlUp).Row)

.NumberFormat = "@" "设置文本格式,防止某些文本数值数据变形

.Value = brr

"brr数组放回单元格区域

End With

Set d = Nothing

"释放字典

MsgBox "合计成绩统计完成。"

End Sub


该段代码只是解决了条件求和的问题,至于同时条件计数……有的朋友可能再声明一个字典……或再写一段代码……

当然,该问题使用两个字典的方法也无不可,只是,如果还需要统计其它字段,例如考试成绩明细、最大分、最小分等等……难不成再声明第3~4~5个字典吗?

——怕啥子呦?想想好像也可以……

……不开玩笑了……前段时间我们说数组 字典是VBA处理数据的最佳利器,可能有些小伙伴对这句话的认识暂时就先停留在上面的代码上,数组单纯的读取单元格数据,字典单纯的存放统计结果,但其实数组和字典的关系可以更紧密些……

比如该示例问题,我们可以声明一个n行3列的数组(crr)用于存放统计结果,第1列存放人名(可以省略),第2列存放考试累加次数,第3列存放考试累加成绩……然后通过字典将该数组和数据源及查询区域关三者联起来……

这么说似乎让人难以理解,代码如下(注意注释):


Sub Dicttl2()

Dim d As Object, arr, brr, crr, i&, j, k&

Set d = CreateObject("scripting.dictionary")

"后期字典

"d.CompareMode = vbTextCompare

"不区分字母大小写

arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)

"数据源装入数组arr

ReDim crr(1 To UBound(arr), 1 To 3)

"声明数组crr放置数据统计结果。1列姓名2列次数3列总成绩。姓名列可以省略。

For i = 1 To UBound(arr)

"先遍历数据源arr

If Not d.exists(arr(i, 1)) Then

"如果字典中不存在姓名……

k = k 1 "累加不重复人名个数,可以先理解成人名在数组crr中的序列号

d(arr(i, 1)) = k

"将数组crr中的序列位置作为item装入字典,以便以后根据人名读取处理

crr(k, 1) = arr(i, 1) "姓名

crr(k, 2) = 1 "考试次数

crr(k, 3) = Val(arr(i, 2)) "考试成绩。val函数提取纯数值,如果是纯文本值则计算为0,该函数可以避免文本值数学运算时出错。

Else

"如果字典中存在相关人名

j = d(arr(i, 1)) "读取人名在数组crr中的序列号

crr(j, 2) = crr(j, 2) 1 "原次数 1

crr(j, 3) = crr(j, 3) Val(arr(i, 2)) "累加成绩

End If

Next

"

brr = Range("d1:f" & Cells(Rows.Count, 4).End(xlUp).Row)

"查询区域装入数组brr

For i = 2 To UBound(brr)

If d.exists(brr(i, 1)) Then

"如果字典中存在查询的姓名

j = d(brr(i, 1)) "姓名在数组brr中的序列号

brr(i, 2) = crr(j, 2) "考试次数

brr(i, 3) = crr(j, 3) "总成绩

Else

"否则返回空文本""

brr(i, 2) = ""

brr(i, 3) = ""

End If

Next

With Range("d1:f" & Cells(Rows.Count, 4).End(xlUp).Row)

.NumberFormat = "@" "设置文本格式,防止某些文本数值数据变形

.Value = brr

"brr数组放回单元格区域

End With

Set d = Nothing

"释放字典

MsgBox "数据统计完成。"

End Sub


小贴士:

1,字典之所以简单又强大,不仅在于它超高的数据处理效率,更在于它可以通过key键及对应项item将多个来源的数据(通常是数组)有机关联起来,使复杂的数据查询与统计变得条理清晰易如反掌。

精彩推荐

粤ICP备16095388号-1