ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > E文精选 > Excel VBA > 字典使用笔记

字典使用笔记

作者：绿色风 分类： 时间：2022-08-17 浏览：188
楼主
liuguansky		 字典笔记.rar

源数据为编号和数量两列，编号为1-100的随机数，数量为1-10000的随机数。
首先是字典最简单也是最根本的一个运用 ，获取编号的不重复清单：

  2. Sub test1() '不重复清单
  3. Rem
  4. ' 相同代码行未作注释，请参照理解
  5. Rem
  6.   Dim dic As Object, i% ' 定义相关变量
  7.     Set dic = CreateObject("scripting.dictionary") ' 创建字典项目
  8.     For i = 2 To Cells(Rows.Count, 1).End(3).Row '循环编号内容区域
  9.       dic(Cells(i, 1).Value) = "" '赋值数组，因为没有使用ITEM，所以可以赋值""，书写方便
  10.     Next i
  11.     Range("c:D").Clear '清空结果返回区域
  12.     Cells(1, 3) = "编号" '设置标题行
  13.     Cells(2, 3).Resize(dic.Count, 1) = Application.Transpose(dic.keys) '依dic.keys的不重复性，返回不重复清单
  14.     Rem DIC.KEYS是一维的行向量，需通过转置返回于列区间
  15.     Set dic = Nothing '清空字典，释放内存
  16. End Sub

第二步，添加了各编号记录个数的统计
  这里是ITEM常量构造的一个例子。代码如下：
  1. Sub test2() '不重复清单及对应个数
  2. Dim dic As Object, i%
  3. Set dic = CreateObject("scripting.dictionary")
  4. For i = 2 To Cells(Rows.Count, 1).End(3).Row
  5. If dic.exists(Cells(i, 1).Value) Then dic(Cells(i, 1).Value) = dic(Cells(i, 1).Value) + 1 Else: dic(Cells(i, 1).Value) = 1
  6. Rem 构造ITEM
  7. '求个数，这里用了构造ITEM为1，进行EXISTS判断后累加处理
  8. Next i
  9. Range("e:G").Clear
  10. Cells(1, 5).Resize(1, 2) = Array("编号", "个数")
  11. Cells(2, 5).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
  12. Cells(2, 6).Resize(dic.Count, 1) = Application.Transpose(dic.items)
  13. Set dic = Nothing
  14. End Sub

第三步，按编号进行汇总数量。代码如下：
  1. Sub test3() '不重复清单并汇总
  2. Dim dic As Object, i%
  3. Set dic = CreateObject("scripting.dictionary")
  4. For i = 2 To Cells(Rows.Count, 1).End(3).Row
  5. If dic.exists(Cells(i, 1).Value) Then dic(Cells(i, 1).Value) = dic(Cells(i, 1).Value) + Cells(i, 2).Value Else: dic(Cells(i, 1).Value) = Cells(i, 2).Value
  6. Rem 构造ITEM
  7. '求数量，这里用了构造ITEM为数量，进行EXISTS判断后累加处理
  8. Next i
  9. Range("H:J").Clear
  10. Cells(1, 8).Resize(1, 2) = Array("编号", "数量")
  11. Cells(2, 8).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
  12. Cells(2, 9).Resize(dic.Count, 1) = Application.Transpose(dic.items)
  13. Set dic = Nothing
  14. End Sub

思维同第二步。
2楼
liuguansky		 第四步，返回编号小于40，数量总计大于10000的汇总结果。代码如下
  1. Sub test4() '数量大于10000,且编号小于40的记录汇总
  2. Dim dic As Object, i&, j&, arr
  3. Set dic = CreateObject("scripting.dictionary")
  4. For i = 2 To Cells(Rows.Count, 1).End(3).Row
  5. If dic.exists(Cells(i, 1).Value) Then dic(Cells(i, 1).Value) = dic(Cells(i, 1).Value) + Cells(i, 2).Value Else: dic(Cells(i, 1).Value) = Cells(i, 2).Value
  6. Next i
  7. ' 先返回各编号数量汇总
  8. arr = dic.keys
  9. For j = 0 To dic.Count - 1
  10. If arr(j) >= 40 Or dic(arr(j)) <= 10000 Then dic.Remove arr(j)
  11. Next j
  12. '再进行条件判断，把不符记录REMOVE，剩余即为所求记录
  13. Range("K:N").Clear
  14. Cells(1, 11).Resize(1, 2) = Array("编号", "数量")
  15. If dic.Count > 0 Then
  16. Cells(2, 11).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
  17. Cells(2, 12).Resize(dic.Count, 1) = Application.Transpose(dic.items)
  18. End If
  19. Set dic = Nothing
  20. End Sub

第五步：编号大于30小于70且数量大于15000,小于45000的汇总结果和记录个数，代码如下：
  1. Sub test5() '编号大于30小于70且数量大于15000,小于45000的记录
  2. Dim dic, i&, j&, m&, arr, arr1
  3. Set dic = CreateObject("scripting.dictionary")
  4. For i = 2 To Cells(Rows.Count, 1).End(3).Row
  5. If dic.exists(Cells(i, 1).Value) Then
  6. dic(Cells(i, 1).Value) = Split(dic(Cells(i, 1).Value), vbTab)(0) + Cells(i, 2).Value & vbTab & Split(dic(Cells(i, 1).Value), vbTab)(1) + 1
  7. Else: dic(Cells(i, 1).Value) = Cells(i, 2).Value & vbTab & 1
  8. End If
  9. Next i
  10. Rem ITEM构造
  11. '在之前基础上，多统计个数，此时构造ITEM时，可以把两个需统计记录用分隔符隔开，EXISTS累加的时，先用SPLIT取两段再累加。
  12. arr = dic.keys
  13. For j = 0 To dic.Count - 1
  14. If Not (arr(j) > 30 And arr(j) < 70 And Split(dic(arr(j)), vbTab)(0) < 45000 And Split(dic(arr(j)), vbTab)(0) > 15000) Then dic.Remove arr(j)
  15. Next j
  16. '再进行条件判断，把不符记录REMOVE，剩余即为所求记录
  17. Range("O:R").Clear
  18. arr1 = dic.items
  19. Cells(1, 14).Resize(1, 3) = Array("编号", "数量", "个数")
  20. If dic.Count > 0 Then
  21. '防止未有符合条件记录，返回错误。
  22. Cells(2, 14).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
  23. For m = 0 To dic.Count - 1
  24. Cells(2 + m, 15).Resize(1, 2) = Application.Transpose(Application.Transpose((Split(arr1(m), vbTab))))
  25. Next m
  26. '转置两次，返回数值结果。
  27. End If
  28. Set dic = Nothing
  29. End Sub

难点：
1.对ITEM多个返回值和构造：<相同编号，其他文本项目连接，数字项目累加>
   
       [quote][上式中如果是文本连接用&，如果是数值相加就用+][/quote]

2.求差集
     

3.如果是差集，或其他返回满足条件记录，为防止DIC.COUNT为0，对返回值处理出错，就对DIC.COUNT进行判断

4.返回值如果是经SPLIT处理的。建议用两次Application.Transpose防止返回数据类型出错
第六步：返回数量大于编号*50,小于编号*200的汇总结果
  1. Sub test6() '数量大于编号*50,小于编号*200的记录
  2. Dim dic, i&, j&, m&, arr, arr1
  3. Set dic = CreateObject("scripting.dictionary")
  4. For i = 2 To Cells(Rows.Count, 1).End(3).Row
  5. If dic.exists(Cells(i, 1).Value) Then
  6. dic(Cells(i, 1).Value) = Split(dic(Cells(i, 1).Value), vbTab)(0) + Cells(i, 2).Value & vbTab & Split(dic(Cells(i, 1).Value), vbTab)(1) + 1
  7. Else: dic(Cells(i, 1).Value) = Cells(i, 2).Value & vbTab & 1
  8. End If
  9. Next i
  10. arr = dic.keys
  11. For j = 0 To dic.Count - 1
  12. If Val(Split(dic(arr(j)), vbTab)(0)) <= arr(j) * 50 Or Val(Split(dic(arr(j)), vbTab)(0)) >= arr(j) * 200 Then dic.Remove arr(j)
  13. Next j
  14. '条件判断，可以KEY与ITEM进行比较
  15. Range("S:V").Clear
  16. arr1 = dic.items
  17. Cells(1, 18).Resize(1, 3) = Array("编号", "数量", "个数")
  18. If dic.Count > 0 Then
  19. Cells(2, 18).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
  20. For m = 0 To dic.Count - 1
  21. Cells(2 + m, 19).Resize(1, 2) = Application.Transpose(Application.Transpose((Split(arr1(m), vbTab))))
  22. Next m
  23. End If
  24. Set dic = Nothing
  25. End Sub


第七步，返回单行记录满足编号大于25，数量大于2500的编号与数量汇总结果及记录个数。代码如下：
  1. Sub test7() '判断单行记录是否满足编号大于25，数量大于2500，返回满足条件的编号与数量汇总清单
  2.   Dim dic, i&, j&, m&, arr, arr1
  3.   Set dic = CreateObject("scripting.dictionary")
  4.   For i = 2 To Cells(Rows.Count, 1).End(3).Row
  5.     If Val(Cells(i, 1).Value) > 25 And Cells(i, 2).Value > 2500 Then
  6.       If dic.exists(Cells(i, 1).Value) Then
  7.           dic(Cells(i, 1).Value) = Split(dic(Cells(i, 1).Value), vbTab)(0) + Cells(i, 2).Value & vbTab & Split(dic(Cells(i, 1).Value), vbTab)(1) + 1
  8.         Else: dic(Cells(i, 1).Value) = Cells(i, 2).Value & vbTab & 1
  9.       End If
  10.     End If
  11.   Next i
  12.   Rem 判断记录后再进行字典处理
  13.     Range("w:z").Clear
  14.     arr1 = dic.items
  15.     Cells(1, 22).Resize(1, 3) = Array("编号", "数量", "个数")
  16.     If dic.Count > 0 Then
  17.     '防止未有符合条件记录，返回错误。
  18.     Cells(2, 22).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
  19.     For m = 0 To dic.Count - 1
  20.       Cells(2 + m, 23).Resize(1, 2) = Application.Transpose(Application.Transpose((Split(arr1(m), vbTab))))
  21.     Next m
  22.     '转置两次，返回数值结果。
  23.     End If
  24.     Set dic = Nothing
  25. End Sub



3楼
wise		 前4题 SQL的写法
  1. select  DISTINCT 编号 from [Sheet1$A:B]
  1. select 编号,count(编号) as 个数 from [Sheet1$A:B] group by 编号
  1. select 编号,sum(数量) as 数量 from [Sheet1$A:B] group by 编号
  1. select  * from (select 编号,sum(数量) as 数量 from  [Sheet1$A:B] group by 编号) where 编号<40 and 数量 >10000
4楼
xihabang		 帮gg 丁丁..明天好好来学习学习
5楼
lisan		 字典看得太晕了，还是3楼wise版主的SQL好理解。谢谢！
6楼
刘志文		 在学习，正需要，谢了！
7楼
snowangle007		 学习了，感觉有点难！
8楼
zyp188c		 学习了，感觉太难了。
9楼
Ltb5907		 学习了，感觉不太清楚！再加强学习吧
10楼
suwenkai		 后面三题，5，6，7的SQL写法。
  1. select 编号,sum(数量) as 数量,count(*) as 个数 from [sheet1$a1:b] where  编号 > 30 and 编号 < 70 group by 编号 having sum(数量) > 15000 and sum(数量) < 45000
  1. select 编号,sum(数量) as 数量,count(*) as 个数 from [sheet1$a1:b]  group by 编号 having sum(数量) > 编号*50 and sum(数量) < 编号*200
  1. select 编号,sum(数量) as 数量,count(*) as 个数 from [sheet1$a1:b] where 编号 > 25 and 数量>2500 group by 编号
11楼
pujizhongxue		 select  DISTINCT 编号 from [Sheet1$A:B]

在vba中使用sql，支持DISTINCT用法吗？
12楼
ctp_119		 支持一下，正找这方面的资料。谢谢！
13楼
bishunbiao		 高级教程，收藏以后学习
14楼
bensonlei		 小七，牛！
15楼
icenotcool

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap