佛山小老鼠带您走进字典(字典入门帖)

佛山小老鼠

第二个案例用字典做查询表

1. 
   
2. Option Explicit
   
3. Sub 查询()
   
4.     Dim dic, arr1, arr2, arr3, arr4(1 To 100, 1 To 2), x&, y&, k& '定义变量
   
5.     Set dic = CreateObject("Scripting.Dictionary") '后期绑定引用字典
   
6.     Range("H2:I100") = "" '清空原有的数据
   
7.     arr1 = Range("A1").CurrentRegion '把区域装到数组arr1
   
8.     arr2 = Range("F1").CurrentRegion '把区域装到数组arr2
   
9.     For x = 2 To UBound(arr1, 1) '循环数组arr1的行
   
10.         dic(arr1(x, 1) & "|" & arr1(x, 2)) = arr1(x, 3) & "|" & arr1(x, 4)
    
11.         '由于两个条件,而关键字只能装一个条件,所以用&把两件条件连起来,中间用"|"分开
    
12.         '同理,由于有二个条目,而一个关键词只能对应一个条目,因此我也是用&连接起来,中间用"|"分开
    
13.         '这样就解决了多行多列装入到字典,间接的突破了字典只能装两列
    
14.     Next x
    
15.     For y = 2 To UBound(arr2, 1) '循环数组arr2的行
    
16.         arr3 = VBA.Split(dic(arr2(y, 1) & "|" & arr2(y, 2)), "|")
    
17.         '根据arr2(y, 1) & "|" & arr2(y, 2))读字典dic里的条目出来,其实它的条目就是我们
    
18.         '刚才arr1后面两列的用"|"的数据,然后用函数Split切开,根据"|",赋值给数组arr3
    
19.         '大家一定要明白,Split通过"|"切开,赋值给数组arr3 数组arr3是一维数组,且它的上标从0开始
    
20.         k = k + 1 '累加k
    
21.         arr4(k, 1) = Val(arr3(0)) '把切开出来的数据放到数组arr4里
    
22.         arr4(k, 2) = Val(arr3(1))
    
23.     Next y
    
24.     [H2].Resize(k, 2) = arr4
    
25. End Sub
    
26. Sub 清空()
    
27.      Range("H2:I100") = ""
    
28. End Sub
    

复制代码

附件在第1楼

佛山小老鼠

第三个案例
透视表式的字典
Option Explicit

1. Sub 透视表式的汇总()
   
2.     Dim arr1, dica, dicb, x&, k&, y&, m&, n&, a&, b&, arr2() '定义相关的变量
   
3.     Set dica = CreateObject("Scripting.Dictionary") '创建两个字典
   
4.     Set dicb = CreateObject("Scripting.Dictionary")
   
5.     arr1 = Range("A1").CurrentRegion '把区域装入数组arr1
   
6.     For x = 2 To UBound(arr1, 1) '循环数组arr1的行
   
7.         If Not dicb.exists(arr1(x, 2)) Then '如果关键字arr1(x,2)不存在,那么
   
8.         '就把它装入字典dicb里,目的就是为了去重
   
9.             k = k + 1 '累加k,目的给dicb做条目
   
10.             dicb(arr1(x, 2)) = k + 1 '这里为什么还要加1呢? 原因在数组arr2里第一列是产品名称
    
11.             '第二放型号"大号",第三列放型号"中号",第四列放型号"小号",第五列是行汇总
    
12.         End If
    
13.     Next x
    
14.     ReDim arr2(1 To 100, 1 To dicb.Count + 2)
    
15.     For y = 2 To UBound(arr1, 1)
    
16.         If dica.exists(arr1(y, 1)) Then '如果字典dica里关键字arr1(y,1)存在,那么就累加arr2数据列
    
17.             a = dica(arr1(y, 1)) '字典dica里关键词arr1(y,1)的条目读出来,目的在是在数组arr2
    
18.             '里找到累加数组arr2那一行,而数组arr2有五列,具体累加到那一列呢?
    
19.             b = dicb(arr1(y, 2)) '字典dicb里的关键词arr1(y,2)的字典读出来,来定位到具体累加到数组arr2那一列
    
20.             arr2(a, b) = arr2(a, b) + arr1(y, 3)
    
21.             arr2(a, 5) = arr2(a, 2) + arr2(a, 3) + arr2(a, 4) '同一行三种型号相加
    
22.         Else
    
23.             m = m + 1 '累加m,目的给dica做条目和数组arr2定位
    
24.             dica(arr1(y, 1)) = m '把arr1(y,1)装入字典dic2,条目为m
    
25.             n = dicb(arr1(y, 2))
    
26.             arr2(m, 1) = arr1(y, 1) '把数组arr1的第一列装入arr2里的第一列
    
27.             arr2(m, n) = arr1(y, 3) '把数组arr1的第三列装入arr2里的第n列
    
28.         End If
    
29.     Next y
    
30.     Range("F1:J" & Rows.Count) = ""
    
31.     [F1] = "产品名称"
    
32.     [G1].Resize(1, dicb.Count) = dicb.keys
    
33.     [G1].Offset(0, dicb.Count) = "行总计"
    
34.     [F2].Resize(dica.Count, dicb.Count + 2) = arr2
    
35. End Sub
    
36. Sub 清空()
    
37.    Range("F1:J" & Rows.Count) = ""
    
38. End Sub
    
39. 
    

复制代码

附件在第1楼

banjinjiu

楼主，请教：
1、dic.Add "不及格", 59，dic("不及格") = "59"有何区别？
2、向单元格填充字典的“关键字”和“项”，是不是这样的？
k = dic.Keys
[a2].Resize(dic.Count, 1) = Application.Transpose(k)
t = dic.Items
[b2].Resize(dic.Count, 1) = Application.Transpose(t)
以下是我的完整代码：

1. Sub test1() '
   
2.     Dim dic
   
3.     Set dic = CreateObject("Scripting.Dictionary")
   
4.     [a1:b1] = Array("成绩类型", "分数段")
   
5.     dic.Add "不及格", 59
   
6.     dic.Add "及格", "大于60"
   
7.     dic("良好") = "70-84"
   
8.     dic("优秀") = "85-99"
   
9.     dic("满分") = 100
   
10.     k = dic.Keys
    
11.    [a2].Resize(dic.Count, 1) = Application.Transpose(k)
    
12.     t = dic.Items
    
13.    [b2].Resize(dic.Count, 1) = Application.Transpose(t)
    
14. End Sub

复制代码

佛山小老鼠

第4个案例
按列拆分成工作表
按列拆分成独立的工作簿

1. 
   
2. Option Explicit
   
3. 
   
4. Sub 按列拆分成工作表()
   
5.     Dim x%, Rg As Range, ColNum&, dic, arr1, y&, arr2, z&
   
6.     Set dic = CreateObject("scripting.dictionary")
   
7.     Sheets("总表").Activate
   
8.     For x = Sheets.Count To 2 Step -1 '删除工作表时要从大到小循环
   
9.         Application.DisplayAlerts = False '关闭询问对话框
   
10.         Sheets(x).Delete '删除工作表
    
11.         Application.DisplayAlerts = True '打开询问对话框
    
12.     Next x
    
13.     '通过InputBox这个方法确定你要拆分的列
    
14.     On Error GoTo 100 '如果有错误跳转到100外
    
15.     Set Rg = Application.InputBox("请选择您要拆分的列", "选择", Type:=8) '用了这句不可以关闭屏幕刷新
    
16.     ColNum = Rg.Column '把要拆分的列赋值变量 ColNum
    
17.     On Error GoTo 0 '下面的代码有错误,继续报错
    
18.     arr1 = Range("a1").CurrentRegion
    
19.         For y = 2 To UBound(arr1)
    
20.             If dic(arr1(y, ColNum)) = "" Then
    
21.             End If
    
22.         Next y
    
23.         arr2 = dic.keys '把字典里的关键词一次性赋值给数组arr2，且是一维数组，编号从0开始
    
24.         For z = 0 To dic.Count - 1 '循环字典的关键词
    
25.             Sheets.Add after:=Sheets(Sheets.Count)
    
26.             Sheets(Sheets.Count).Name = arr2(z)
    
27.             Sheets("总表").Activate '由于新建后活动表会转到最后一个工作表，要重新选择“总表”为活动工作表进行筛选
    
28.            Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).AutoFilter ColNum, arr2(z)
    
29.             '方法AutoFilter第一参数筛选哪一列，第二参数筛选关键词
    
30.              Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).SpecialCells(xlCellTypeVisible).Copy Sheets(Sheets.Count).Range("A1") '定位可见单元格
    
31.             '如果那一列是数据化,大家一定要注意,不能用sheets(arr2(z)表示工作表,要用sheets(sheets.count)表示
    
32.             '这样程序就通用
    
33.         Next z
    
34.             Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).AutoFilter
    
35.     Exit Sub
    
36. 100:
    
37.     MsgBox "您选择了取消或者是关闭，即将退出程序", 64, "温馨提示"
    
38. End Sub
    

复制代码

1. Option Explicit
   
2. Sub 按列拆分成独立的工作簿()
   
3.     Dim x%, Rg As Range, ColNum&, dic, arr1, y&, arr2, z&, St, StFile$, a%, b%, wb As Workbook
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     St = Application.FileDialog(msoFileDialogFolderPicker).Show '如果你选择了文件夹就返回-1,不选择文件夹
   
6.     '就返回0,相当于你按了取消和关闭按钮
   
7.     If St <> 0 Then
   
8.         StFile = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
   
9.         '取得你选择的那个文件夹路径
   
10.     Else
    
11.         Exit Sub
    
12.     End If
    
13.     Sheets("总表").Activate
    
14.     For x = Sheets.Count To 2 Step -1 '删除工作表时要从大到小循环
    
15.         Application.DisplayAlerts = False '关闭询问对话框
    
16.         Sheets(x).Delete '删除工作表
    
17.         Application.DisplayAlerts = True '打开询问对话框
    
18.     Next x
    
19.     '通过InputBox这个方法确定你要拆分的列
    
20.     On Error GoTo 100 '如果有错误跳转到100外
    
21.     Set Rg = Application.InputBox("请选择您要拆分的列", "选择", Type:=8) '用了这句不可以关闭屏幕刷新
    
22.     ColNum = Rg.Column '把要拆分的列赋值变量 ColNum
    
23.     On Error GoTo 0 '下面的代码有错误,继续报错
    
24.     arr1 = Range("a1").CurrentRegion
    
25.         For y = 2 To UBound(arr1)
    
26.             If dic(arr1(y, ColNum)) = "" Then
    
27.             End If
    
28.         Next y
    
29.         arr2 = dic.keys '把字典里的关键词一次性赋值给数组arr2，且是一维数组，编号从0开始
    
30.         For z = 0 To dic.Count - 1 '循环字典的关键词
    
31.             Sheets.Add after:=Sheets(Sheets.Count)
    
32.             Sheets(Sheets.Count).Name = arr2(z)
    
33.             Sheets("总表").Activate '由于新建后活动表会转到最后一个工作表，要重新选择“总表”为活动工作表进行筛选
    
34.            Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).AutoFilter ColNum, arr2(z)
    
35.             '方法AutoFilter第一参数筛选哪一列，第二参数筛选关键词
    
36.              Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).SpecialCells(xlCellTypeVisible).Copy Sheets(Sheets.Count).Range("A1") '定位可见单元格
    
37.             '如果那一列是数据化,大家一定要注意,不能用sheets(arr2(z)表示工作表,要用sheets(sheets.count)表示
    
38.             '这样程序就通用
    
39.         Next z
    
40.             Range(Cells(1, 1), Cells(UBound(arr1, 1), UBound(arr1, 2))).AutoFilter '取消筛选
    
41.             Application.DisplayAlerts = False '关闭询问对话框
    
42.             For a = 2 To Sheets.Count '循环总表后面的分表
    
43.                 Sheets(a).Copy '依次复制分表成独立的工作簿
    
44.                 Set wb = ActiveWorkbook '把分表折成的独立的工作簿设置为活动工作簿
    
45.                 With wb
    
46.                     .SaveAs Filename:=StFile & "" & Sheets(1).Name & ".xls", FileFormat:=xlExcel8 '把新的工作簿保存为规定的文件夹下
    
47.                     .Close True '关闭工作簿,且保存
    
48.                 End With
    
49.             Next a
    
50.             For b = Sheets.Count To 2 Step -1 '删除"总表"工作表后面所有工作表
    
51.                 Sheets(b).Delete
    
52.             Next b
    
53.              Application.DisplayAlerts = True '打开询问对话框
    
54.             MsgBox "亲,拆分完毕,请查阅", 64, "温馨提示"
    
55.             Shell "explorer.exe " & StFile, 1 '显示拆分后的,便于查询,大家要注意思exe后面有一个空格
    
56.     Exit Sub
    
57. 100:
    
58.     MsgBox "您选择了取消或者是关闭，即将退出程序", 64, "温馨提示"
    
59. End Sub
    
60. 
    

复制代码

附件在第1楼

佛山小老鼠

banjinjiu 发表于 2013-11-3 17:32
楼主，请教：
1、dic.Add "不及格", 59，dic("不及格") = "59"有何区别？
2、向单元格填充字典的“关键字 ...

dic.Add "不及格", 59
dic("不及格") = 59
这是两种向字典时添加关键字和条目的方法
帖里有说明,你没有仔细看
主要是对重复的数据来说才有意义,如果没有重复则是一样的
第一种方法:如果有重复的,只装进第一个关键词和条目
第二种方法:如果有重复的,是装进最后一个重复的关键词和条目

龙蒙山

佛山小老鼠 发表于 2013-11-3 17:22
第三个案例
透视表式的字典
Option Explicit

老师的字典用法讲得通俗易懂，非常好！谢谢！
学习“透视表式字典”有个问题请教一下：怎么样能使代码变成通用的，将型号列自由添加，行合计数对应“行合计”列？
谢谢！

zbkfbyb

学习了，值得学习

ctp_119

感谢老鼠老师的原创！！！

fxwang1967

多谢版主！

ccwan

留个脚印{:soso_e121:}