送人玫瑰,手有余香,请将文章分享给更多朋友
动手操作是熟练掌握EXCEL的最快捷途径!
【置顶公众号】或者【设为星标】及时接收更新不迷路
小伙伴们好,今天来和大家分享一则VBA字典的题目。其实这个类型的题目经常会遇到,并且如果你可以使用高版本函数,那可以很好的解决这个问题。
今天则用一段代码来处理这个题目。原题是这样的:
题目要求按照类别来汇总左侧的数据。结果如右侧。
完整代码如下:
Sub 合并同类项()
Dim i As Integer, myarr As Variant, mydic As Object, brr(), d, r
Set mydic = CreateObject("scripting.dictionary")
myarr = Range("A1").CurrentRegion
For i = 1 To UBound(myarr)
If mydic.exists(myarr(i, 1) & "-" & myarr(i, 3)) Then
mydic(myarr(i, 1) & "-" & myarr(i, 3)) = _
mydic(myarr(i, 1) & "-" & myarr(i, 3)) & "、" & myarr(i, 2)
Else
mydic(myarr(i, 1) & "-" & myarr(i, 3)) = myarr(i, 2)
End If
Next i
ReDim brr(1 To mydic.Count, 1 To UBound(myarr, 2))
For Each d In mydic.keys
r = r + 1
brr(r, 1) = Split(d, "-")(0)
brr(r, 2) = mydic(d)
brr(r, 3) = Split(d, "-")(1)
Next
[E10].Resize(UBound(brr), 3) = brr
End Sub
其中:
For i = 1 To UBound(myarr)
If mydic.exists(myarr(i, 1) & "-" & myarr(i, 3)) Then
mydic(myarr(i, 1) & "-" & myarr(i, 3)) = _
mydic(myarr(i, 1) & "-" & myarr(i, 3)) & "、" & myarr(i, 2)
Else
mydic(myarr(i, 1) & "-" & myarr(i, 3)) = myarr(i, 2)
End If
Next i
第5-12行代码:创建字典。将源数据第1列和第3列组合后作为键,并通过循环不断进行同类项值的合并。
注意,这里使用了IF语句,当键不在字典中时,创建后首先要对其赋值,然后再在此基础上循环合并同类的数据。如果不这样,就要添加On Error语句。
ReDim brr(1 To mydic.Count, 1 To UBound(myarr, 2))
第13行代码,重新定义动态数组brr
For Each d In mydic.keys
r = r + 1
brr(r, 1) = Split(d, "-")(0)
brr(r, 2) = mydic(d)
brr(r, 3) = Split(d, "-")(1)
Next
第14-19行代码:再次通过For Each语句循环将键拆分后复制给动态数组brr
-END- 我就知道你“在看”
联系客服