admin 管理员组文章数量: 1086019
2024年4月30日发(作者：下拉表格怎么设置)
VBA 字典法学习与例子
Sub 二列多行求和()
Dim arr1, dic, x, arr2(1 To 10, 1 To 2), m%, k% '定义变量
Set dic = CreateObject("nary") '后期绑定引用字典
arr1 = Range("A1").CurrentRegion '把单元区域装到数组arr1
For x = 2 To UBound(arr1, 1) '循环数组arr1的行
If (arr1(x, 1)) Then '判断数组元素arr1(x,1)在字典关键词里是否存在，
m = dic(arr1(x, 1)) '如果存在，把关键词arr1(x,1)的条目读出来，在原来的
'基础上累加，通过读取关键词arr1(x,1)的条目，找到在数组arr2那一行上累加
arr2(m, 2) = arr2(m, 2) + arr1(x, 2) '在数组arr2第m行，第2列上累加
Else '如果关键词arr1(x,1)不存在，那么
k = k + 1 '计数
dic(arr1(x, 1)) = k '把数组arr1(x,1)装到字典dic里，条目装一个k,
'这个k的作用来给数组arr2中找到存放那一行
arr2(k, 1) = arr1(x, 1) '把数组arr1里的第x行第1列装到数组arr2的第k行，第1列
arr2(k, 2) = arr1(x, 2) '把数组arr1里的第x行第2列装到数组arr2的第k行，第2列
End If
Next x
Range("E1:F" & ) = "" '清空区域，用来存放新的数据
[E1:F1] = Array("产品名称", "数量") '填充表头
[E2].Resize(k, 2) = arr2 '把数组arr2读到单元格区域
End Sub
2020-8-31
Sub 多列多行汇总()
Dim dic, arr1, x%, MySt, k%, arr2(1 To 15, 1 To 3), y%, m%
Set dic = CreateObject("nary")
arr1 = Range("A1").CurrentRegion
For x = 2 To UBound(arr1, 1)
MySt = arr1(x, 1) & arr1(x, 2)
If (MySt) Then
m = dic(MySt)
arr2(m, 3) = arr2(m, 3) + arr1(x, 3)
Else
k = k + 1
dic(MySt) = k
For y = 1 To 3
arr2(k, y) = arr1(x, y)
Next y
End If
Next x
Range("E1:G" & ) = ""
[E1:G1] = Array("产品名称", "款号", "数量")
[E2].Resize(k, 3) = arr2
End Sub
产品名称 款号
WS-10
WS-10
WS-10
VZ-45
VZ-45
VZ-45
WS-10
VZ-45
A
B
C
A
B
C
A
A
数量
1
2
3
1
2
3
99
999
产品名称 款号
WS-10
WS-10
WS-10
VZ-45
VZ-45
VZ-45
A
B
C
A
B
C
数量
100
2
3
1000
2
3
Sub 删除重复数据－根据A列内容，保存表格内数据最上面一行，删除下面的重复行
Set d = CreateObject("nary")
Set Rng = Nothing
arr = [a1].CurrentRegion
Updating = False
For j = 1 To UBound(arr)
If (arr(j, 1)) Then
If Rng Is Nothing Then
Set Rng = Cells(j, 1)
Else
Set Rng = Union(Rng, Cells(j, 1))
End If
Else
d(arr(j, 1)) = ""
End If
Next j
If Not Rng Is Nothing Then
Updating = True
End Sub
客户姓名 月份 消费数量
A1 1 10
A2 1 10
A1 1 10
A2 1 10
A3 2 10
A4 2 10
A5 2 10
A3 2 10
A4 2 10
A5 2 10
A6 3 10
A7 3 10
A6 3 10
A7 3 10
A8 4 10
A4 4 10
A8 4 10
A4 4 10
A5 5 10
A6 5 10
A5 5 10
A6 5 10
A1 6 10
A10 6 10
A1 6 10
A10 6 10
A8 7 10
A9 7 10
A8 7 10
A9 7 10
Sub 根据内容查询对应数据
Dim dic, arr1, arr2, arr3, arr4(1 To 100, 1 To 2), x& y& k& '定义变量
Set dic = CreateObject("nary") '后期绑定引用字典
Range("H2:I100") = "" '清空原有的数据
arr1 = Range("A1").CurrentRegion '把区域装到数组arr1
arr2 = Range("F1").CurrentRegion '把区域装到数组arr2
For x = 2 To UBound(arr1, 1) '循环数组arr1的行
dic(arr1(x, 1) & "|" & arr1(x, 2)) = arr1(x, 3) & "|" & arr1(x, 4)
'由于两个条件，而关键字只能装一个条件，所以用&把两件条件连起来，中间用"|"分
开
'同理，由于有二个条目，而一个关键词只能对应一个条目，因此我也是用&连接起来，
中间用"|"分开
'这样就解决了多行多列装入到字典，间接地突破了字典只能装两列
Next x
For y = 2 To UBound(arr2, 1) '循环数组arr2的行
arr3 = (dic(arr2(y, 1) & "|" & arr2(y, 2)), "|")
'根据arr2(y, 1) & "|" & arr2(y, 2)）读字典dic里的条目出来，其实它的条目就是我们
'刚才arr1后面两列的用"|"的数据，然后用函数Split切开，根据"|"，赋值给数组arr3
'大家一定要明白，Split通过"|"切开，赋值给数组arr3 数组arr3是一维数组，且它的
上标从0开始
k = k + 1 '累加k
arr4(k, 1) = Val(arr3(0)) '把切开出来的数据放到数组arr4里
arr4(k, 2) = Val(arr3(1))
Next y
[H2].Resize(k, 2) = arr4
Sub 透视表示的汇总()
Dim arr1, dica, dicb, x& k& y& m& n& a& b& arr2() '定义相关的变量
Set dica = CreateObject("nary") '创建两个字典
Set dicb = CreateObject("nary")
arr1 = Range("A1").CurrentRegion '把区域装入数组arr1
For x = 2 To UBound(arr1, 1) '循环数组arr1的行
If Not (arr1(x, 2)) Then '如果关键字arr1(x,2)不存在，那么
'就把它装入字典dicb里，目的就是为了去重
k = k + 1 '累加k，目的给dicb做条目
dicb(arr1(x, 2)) = k + 1 '这里为什么还要加1呢？ 原因在数组arr2里第一列是产品名称
'第二放型号"大号"，第三列放型号"中号"，第四列放型号"小号"，第五列是行汇总
End If
Next x
ReDim arr2(1 To 100, 1 To + 2)
For y = 2 To UBound(arr1, 1)
If (arr1(y, 1)) Then '如果字典dica里关键字arr1(y,1)存在，那么就累加arr2数据
列
a = dica(arr1(y, 1)) '字典dica里关键词arr1(y,1)的条目读出来，目的在是在数组arr2
'里找到累加数组arr2那一行，而数组arr2有五列，具体累加到那一列呢？
b = dicb(arr1(y, 2)) '字典dicb里的关键词arr1(y,2)的字典读出来，来定位到具体累加到数
组arr2那一列
arr2(a, b) = arr2(a, b) + arr1(y, 3)
arr2(a, 5) = arr2(a, 2) + arr2(a, 3) + arr2(a, 4) '同一行三种型号相加
Else
m = m + 1 '累加m，目的给dica做条目和数组arr2定位
dica(arr1(y, 1)) = m '把arr1(y,1)装入字典dic2，条目为m
n = dicb(arr1(y, 2))
arr2(m, 1) = arr1(y, 1) '把数组arr1的第一列装入arr2里的第一列
arr2(m, n) = arr1(y, 3) '把数组arr1的第三列装入arr2里的第n列
End If
Next y
Range("F1:J" & ) = ""
[F1] = "产品名称"
[G1].Resize(1, ) =
[G1].Offset(0, ) = "行总计"
[F2].Resize(, + 2) = arr2
End Sub
版权声明：本文标题：VBA字典典型案例学习必背代码 内容由网友自发贡献，该文观点仅代表作者本人， 转载请联系作者并注明出处：http://roclinux.cn/p/1714442595a680327.html， 本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌抄袭侵权/违法违规的内容，一经查实，本站将立刻删除。
发表评论