第5部分 字典
5.1 什么是字典？
- 定义：字典是一种用于存储键值对数据结构的对象
- 优点：可以快速查找、添加和删除键值对，并提供高效的数据存取方式
- 键值对：由一个唯一的键和一个与之相关联的值组成
- 1. 键（Key）：
- 每个键在字典中是唯一的，不允许重复
- 键是字典中唯一的标识符，用于索引和检索值（例如在5.3字典Item 和 Key 属性中获取对应的键或者值都是用key去查找）
- 键可以是任何简单数据类型，例如字符串、整数等
- 2. 值（Item）
- 值是与键相关联的数据
- 值可以是任何数据类型，包括简单类型（如字符串、整数）、对象、数组等
- 示例：值为数组
Sub DictionaryWithArrayValues() ' 创建字典对象 Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") ' 创建第一个数组arr1并赋值 Dim arr1() As Variant arr1 = Array("Apple", "Banana", "Cherry") ' 数组包含三种水果 ' 创建第二个数组arr2并赋值 Dim arr2() As Variant arr2 = Array("Carrot", "Potato", "Tomato") ' 数组包含三种蔬菜 ' 将数组添加到字典中，以键值对的形式存储 dict.Add "Fruits", arr1 dict.Add "Vegetables", arr2 ' 访问和打印字典中的数组 Dim fruitArr() As Variant fruitArr = dict("Fruits") ' 访问字典中的Fruits数组 Debug.Print "Fruits:" Dim i As Integer For i = LBound(fruitArr) To UBound(fruitArr) ' 遍历数组并打印每个元素 Debug.Print fruitArr(i) Next i Dim vegArr() As Variant vegArr = dict("Vegetables") ' 访问字典中的Vegetables数组 Debug.Print "Vegetables:" For i = LBound(vegArr) To UBound(vegArr) ' 遍历数组并打印每个元素 Debug.Print vegArr(i) Next i End Sub
- 1. 键（Key）：
5.2 字典创建与绑定
5.2.1 前期绑定
- 方法：需要在VBA编辑器中引用 Microsoft Scripting Runtime 库
- 步骤：
- 1. 宏——工具——引用——浏览文件夹——找到scrrun.dll
- 2. 引用里面勾选Microsoft Scripting Runtime——点击确定
- 3. 代码：
' 直接声明为新字典就可以使用 Dim dict As New Dictionary
5.2.2 后期绑定
- 方法：不需要引用外部库，代码会在运行时绑定
- 步骤：
- 使用CreateObject方法创建字典对象实例Set dict = CreateObject("Scripting.Dictionary")
- 代码：
' 先声明再创建字典对象 Dim dict As Object Set dict = CreateObject("Scripting.Dictionary")
5.2.3 区别总结
| 区别 | 前期绑定 | 后期绑定 |
| 引用库 | 需要 | 不需要 |
| 代码补全和语法检查 | 支持 | 不支持 |
| 执行速度 | 较快 | 较慢 |
| 适用性 | 开发和调试阶段，方便检查提高效率 | 便于使用者，在不确保目标环境中引用了特定库时可以更灵活地使用 |
5.3 字典属性
5.3.1 Item 属性
-
作用：获取或设置某个键对应的值
- 语法：
- 获取值：MsgBox dict.Item("Key1")
- 设置值：dict.Item("Key1") = "NewValue1"
5.3.2 Key 属性
- 作用：获取或设置某个值对应的关键字
- 语法：
- 获取键：MsgBox dict.Key("OldKey")
- 设置键：dict.Key("OldKey") = "NewKey"
- 注意点：因为键是字典中唯一的标识符，用于索引和检索值，所以Item 和 Key 属性括号里面的都是键（Key）
5.3.3 Count 属性
- 作用：获取字典中键值对的数量
- 语法：dict.Count
5.3.4 Comparemode 属性
- 作用：设置或获取字典的比较模式
- 比较模式：是否区分大小写，0表示vbBinaryCompare区分，1表示vbTextCompare不区分
- 设置时机：在添加任何键值对之前设置（也就是Add 方法前）。如果在添加键值对之后尝试设置 CompareMode，会引发错误
- 语法：dict.CompareMode = 0或者1，也可以是 = vbBinaryCompare或者vbTextCompare
5.4 字典方法
5.4.1 常用方法
| 方法 | 语法 | 作用 |
| Add 方法 | dict.Add "Key1", "Item1" | 添加键值对 |
| Keys 方法 | dict.Keys | 获取字典中所有键的数组 |
| dict.Keys()(n) | 获取字典中第n个键 | |
| Items 方法 | dict.Items | 获取字典中所有值的数组 |
| dict.Items()(n) | 获取字典中第n个值 | |
| Exists 方法 | dict.Exists("Key1") | 检查字典中是否存在某个键，存在则返回True |
| Remove 方法 | dict.Remove "Key1" | 删除字典中的某个键值对，一次删除一个，Key和Value成对删除 |
| RemoveAll 方法 | dict.RemoveAll | 清空字典，移除所有关键字和对应条目 |
5.4.2 字典写入 Excel 表格
- 示例：假设要把字典键写入工作表ws的A列，字典值写入B列
- 方法：
- 先用d.Count对单元格范围大小进行调整，使其与字典的项目数相同
- 然后把字典的键/值转置为垂直方向的数组，以便写入到工作表的列中
ws.Range("A1").Resize(d.Count) = WorksheetFunction.Transpose(d.Keys) ws.Range("B1").Resize(d.Count) = WorksheetFunction.Transpose(d.Items)
5.4.3 只清空字典的值
- 前提：在VBA字典中Remove 方法是同时删除键和值，没有直接的方法来清空值而保留键
- 方法：通过遍历字典并重置每个键的值来实现这一点
- 示例：已创建字典对象dict，把dict中的所有值变为空字符串
' 清空值但保留键 For Each key In dict.Keys dict(key) = "" ' 将值重置为空字符串，或其他默认值 Next key
5.5 嵌套字典
- 含义：一个字典中可以包含另一个字典作为值
- 使用场景：适合处理复杂、多维度的层次化数据
- 优点：结构清晰、可读性高、灵活性高、易于扩展和便于数据处理
- 示例：创建一个字典对象 employees，再使用嵌套数组存储所有员工的基本信息、联系信息和职位信息
Sub NestedDictionaryExample() ' 创建外层字典，用于存储所有员工的信息 Dim employees As Object Set employees = CreateObject("Scripting.Dictionary") ' 创建第一个员工的信息字典 Dim emp1 As Object Set emp1 = CreateObject("Scripting.Dictionary") ' 添加基本信息 emp1.Add "Name", "Alice" emp1.Add "Age", 30 ' 创建并添加联系信息字典 Dim contact1 As Object Set contact1 = CreateObject("Scripting.Dictionary") contact1.Add "Email", "alice@example.com" contact1.Add "Phone", "123-456-7890" emp1.Add "Contact", contact1 ' 创建并添加职位信息字典 Dim position1 As Object Set position1 = CreateObject("Scripting.Dictionary") position1.Add "Department", "HR" position1.Add "Title", "Manager" emp1.Add "Position", position1 ' 将第一个员工的信息添加到外层字典 employees.Add "E001", emp1 ' 创建第二个员工的信息字典 Dim emp2 As Object Set emp2 = CreateObject("Scripting.Dictionary") emp2.Add "Name", "Bob" emp2.Add "Age", 25 ' 创建并添加联系信息字典 Dim contact2 As Object Set contact2 = CreateObject("Scripting.Dictionary") contact2.Add "Email", "bob@example.com" contact2.Add "Phone", "098-765-4321" emp2.Add "Contact", contact2 ' 创建并添加职位信息字典 Dim position2 As Object Set position2 = CreateObject("Scripting.Dictionary") position2.Add "Department", "IT" position2.Add "Title", "Developer" emp2.Add "Position", position2 ' 将第二个员工的信息添加到外层字典 employees.Add "E002", emp2 ' 访问并打印员工信息 Dim emp As Object ' 打印第一个员工的信息 Set emp = employees("E001") Debug.Print "Employee ID: E001" Debug.Print "Name: " & emp("Name") Debug.Print "Age: " & emp("Age") Debug.Print "Email: " & emp("Contact")("Email") ' 访问嵌套字典中的Email Debug.Print "Phone: " & emp("Contact")("Phone") ' 访问嵌套字典中的Phone Debug.Print "Department: " & emp("Position")("Department") ' 访问嵌套字典中的Department Debug.Print "Title: " & emp("Position")("Title") ' 访问嵌套字典中的Title ' 打印第二个员工的信息 Set emp = employees("E002") Debug.Print "Employee ID: E002" Debug.Print "Name: " & emp("Name") Debug.Print "Age: " & emp("Age") Debug.Print "Email: " & emp("Contact")("Email") Debug.Print "Phone: " & emp("Contact")("Phone") Debug.Print "Department: " & emp("Position")("Department") Debug.Print "Title: " & emp("Position")("Title") End Sub
5.6 字典使用案例
5.6.1 使用前提
区分添加字典的两种方法
- d.Add arr(i), ""：
- 如果键不存在，则添加键并设置值；如果键存在，则引发错误，需要在前面加一句 On Error Resume Next或者增加 If 判断
- 可以确保每个键唯一且只添加一次
- 如果需要记录第一个出现的键值对，使用 d.Add
- d(arr(i)) = ""：
- 如果键不存在，则添加键并设置值；如果键存在，则更新值
- 允许更新现有键的值
- 如果需要记录最后一个出现的键值对，使用 d(arr(i))
- 示例：使用字典来提取客户的第一次和最后一次消费记录
- d.Add arr(i), "" 提取客户的第一次消费记录
- d(arr(i)) = "" 提取客户的最后一次消费记录
Sub ExtractCustomerRecords() Dim arr() As Variant Dim dictFirst As Object Dim dictLast As Object Dim i As Long ' 初始化数组，假设数据格式为：客户姓名, 消费时间 arr = Array( _ Array("Alice", "2023-01-01"), _ Array("Bob", "2023-01-02"), _ Array("Alice", "2023-01-05"), _ Array("Bob", "2023-01-03"), _ Array("Alice", "2023-01-03") _ ) ' 创建字典对象 Set dictFirst = CreateObject("Scripting.Dictionary") Set dictLast = CreateObject("Scripting.Dictionary") ' 提取第一次消费记录 For i = LBound(arr) To UBound(arr) If Not dictFirst.exists(arr(i)(0)) Then dictFirst.Add arr(i)(0), arr(i)(1) End If Next i ' 提取最后一次消费记录 For i = LBound(arr) To UBound(arr) dictLast(arr(i)(0)) = arr(i)(1) Next i ' 打印第一次消费记录 Debug.Print "第一次消费记录:" For Each key In dictFirst.Keys Debug.Print key & ": " & dictFirst(key) Next key ' 打印最后一次消费记录 Debug.Print "最后一次消费记录:" For Each key In dictLast.Keys Debug.Print key & ": " & dictLast(key) Next key End Sub
5.6.2 数据查找和映射
- 字典可以高效地用于数据查找和映射，比如快速查找某个键对应的值
Sub DataMappingExample() Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") ' 添加数据到字典 dict.Add "John", 1001 dict.Add "Alice", 1002 dict.Add "Bob", 1003 ' 查找员工编号 Dim employeeName As String employeeName = "Alice" If dict.exists(employeeName) Then Debug.Print "员工 " & employeeName & " 的编号是: " & dict(employeeName) Else Debug.Print "找不到员工 " & employeeName End If End Sub
5.6.3 去重
-
字典的键具有唯一性，可以用于去重
-
推荐使用 `d(arr(i,1)) = ""` 方法，可以简化去重操作，并且不会引发错误
-
示例：对数组里的数据进行去重操作
Sub RemoveDuplicatesUsingDict() Dim dict As Object Dim arr As Variant Dim i As Long ' 初始化数组，包含一些重复值 arr = Array("apple", "banana", "cherry", "apple", "banana", "date") ' 创建字典对象 Set dict = CreateObject("Scripting.Dictionary") ' 使用字典去重 For i = LBound(arr) To UBound(arr) dict(arr(i)) = "" Next i ' 输出去重后的结果 Dim key As Variant For Each key In dict.Keys Debug.Print key Next key End Sub
5.6.4 分类汇总
- 方法：d(arr(i,1)) = d(arr(i,1)) +arr(i,2)
- 含义：如果字典中不存在某个类别，则添加该类别并初始化其值为0；如果字典中已经存在该类别，则累加相应的值
- 示例：假设有一批销售记录，其中包含商品类别和销售金额，我们将使用字典来分类汇总每个类别的总销售额
Sub CategorySalesSummary() ' 创建字典对象 Dim salesSummary As Object Set salesSummary = CreateObject("Scripting.Dictionary") ' 模拟销售记录（假设格式：类别，销售金额） Dim salesRecords As Variant salesRecords = Array(Array("Electronics", 100), _ Array("Clothing", 50), _ Array("Electronics", 200), _ Array("Groceries", 30), _ Array("Clothing", 70), _ Array("Groceries", 50), _ Array("Electronics", 150)) ' 分类汇总销售金额 Dim i As Integer For i = LBound(salesRecords) To UBound(salesRecords) Dim category As String Dim amount As Double category = salesRecords(i)(0) amount = salesRecords(i)(1) ' 累加销售金额 salesSummary(category) = salesSummary(category) + amount Next i ' 打印每个类别的总销售额 Dim key As Variant Debug.Print "类别", "总销售额" For Each key In salesSummary.Keys Debug.Print key, salesSummary(key) Next key End Sub
5.6.5 合并多个数据源
- 字典可以用于合并多个数据源的信息，并确保数据的唯一性和一致性
- 示例：假设Sheet1和Sheet2中有员工姓名和编号，但是里面有部分数据是重复的，现在我们需要统计公司员工的唯一名单，将其合并汇总
Sub MergeDataFromMultipleSheets() ' 创建字典对象 Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") ' 读取第一个工作表的数据 Dim ws1 As Worksheet Set ws1 = ThisWorkbook.Sheets("Sheet1") Dim lastRow As Long Dim i As Long ' 获取Sheet1的最后一行 lastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row ' 将Sheet1的数据添加到字典 For i = 1 To lastRow dict(ws1.Cells(i, 1).Value) = ws1.Cells(i, 2).Value Next i ' 读取第二个工作表的数据 Dim ws2 As Worksheet Set ws2 = ThisWorkbook.Sheets("Sheet2") ' 获取Sheet2的最后一行 lastRow = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row ' 将Sheet2的数据添加到字典 For i = 1 To lastRow dict(ws2.Cells(i, 1).Value) = ws2.Cells(i, 2).Value Next i ' 遍历字典，打印合并后的数据 Dim key As Variant For Each key In dict.Keys Debug.Print key & ": " & dict(key) Next key End Sub
5.6.6 抽奖
- 示例：从一个原始名单中随机选取人员，生成指定组数、每组固定人数的不重复名单
- 思路：
- 1. 把原始名单写入字典，通过 InputBox 获取用户输入的组数和每组人数
- 2. 检查总人数是否足够分组，创建二维数组用于存储分组结果
- 3. 用 randIndex 生成一个随机索引，从字典中选取一个随机人名放入数组中，将已选取的人名从字典中移除以避免重复
- 注意：示例中给出的名单人数为10，测试时组数*每组人数不要超过10人
Sub GenerateRandomGroups() ' 原始名单 Dim originalList As Variant originalList = Array("Alice", "Bob", "Charlie", "David", "Eve", "Frank", "Grace", "Hannah", "Ivy", "Jack") ' 创建字典对象并将名单写入字典 Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") Dim i As Integer For i = LBound(originalList) To UBound(originalList) dict.Add i, originalList(i) Next i ' 用户输入组数和每组人数 Dim groupCount As Integer Dim groupSize As Integer groupCount = InputBox("请输入组数：") groupSize = InputBox("请输入每组人数：") ' 检查总人数是否足够分组 If groupCount * groupSize > dict.Count Then MsgBox "总人数不足以分配到指定组数和人数。", vbExclamation Exit Sub End If ' 创建二维数组用于存储分组结果 Dim groups() As Variant ReDim groups(1 To groupCount, 1 To groupSize) Dim randIndex As Integer Dim g As Integer, p As Integer ' 随机选取不重复的人分配到组 For g = 1 To groupCount For p = 1 To groupSize randIndex = Int((dict.Count - 1 + 1) * Rnd) groups(g, p) = dict.Items()(randIndex) dict.Remove dict.Keys()(randIndex) Next p Next g ' 打印分组结果 Dim groupStr As String For g = 1 To groupCount groupStr = "组 " & g & ": " For p = 1 To groupSize groupStr = groupStr & groups(g, p) & " " Next p Debug.Print groupStr Next g End Sub
5.6.7 动态工作簿
- 示例：假设名单保存在一个数组中，并且代码会根据这个数组的变化动态更新工作簿中的工作表，在工作簿中添加或删除工作表
- 思路：
- 1. 记录当前工作表名字：遍历当前工作簿中的所有工作表，并将它们的名字记录到一个字典中
- 2. 添加缺少的工作表：遍历名单数组，检查每个名字是否在字典中。如果不在，则添加一个新的工作表，并将其命名为该名字；如果在，则从字典中删除该名字（方便第三步检查，因为名单是变动的，可能存在工作表的名字不在名单中的情况）
- 3. 删除多余的工作表：再次遍历工作簿中的所有工作表，检查每个工作表的名字是否仍在字典中。如果在，说明工作表是多余的，则删除该工作表
- 代码：
Sub UpdateWorksheets() ' 声明变量 Dim ws As Worksheet Dim sheetNames As Object Dim nameArray() As String Dim i As Integer ' 初始化名字数组（可以根据需要修改） nameArray = Array("Alice", "Bob", "Charlie", "David") ' 创建字典对象存储当前工作簿中的工作表名字 Set sheetNames = CreateObject("Scripting.Dictionary") ' 遍历工作簿中的所有工作表，记录其名字 For Each ws In ThisWorkbook.Worksheets sheetNames.Add ws.Name, True Next ws ' 添加不存在的工作表 For i = LBound(nameArray) To UBound(nameArray) If Not sheetNames.Exists(nameArray(i)) Then ' 如果字典中不存在名字，则添加工作表 Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) ws.Name = nameArray(i) Else ' 如果存在，则从字典中删除名字 sheetNames.Remove nameArray(i) End If Next i ' 删除多余的工作表 For Each ws In ThisWorkbook.Worksheets If sheetNames.Exists(ws.Name) Then ' 如果字典中还存在名字，表示该工作表应被删除 Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Next ws End Sub
5.6.8 对账
- 示例：从Sheet1和Sheet2两个不同的工作表中读取订单号和金额数据，分别进行分类汇总，并将结果写入到一个【对账单】表格中。方便比较不同表中的订单金额是否一致。
- 注意：示例中的每张表都有表头，取数从第二行开始取，粘贴在对账单中也是从第二行开始
- 步骤：
- 从Sheet1读取订单号和金额，并将金额按订单号汇总到字典中
- 将Sheet1的汇总结果写入“对账单”表的A列和B列
- 清空字典中的金额，保留订单号（方便后面两步的操作，Sheet2中的订单号如果在Sheet1中没有，那么会新增到字典的最下面，不改变原有字典订单号的顺序）
- 从Sheet2读取订单号和金额，并将金额按订单号汇总到字典中
- 将Sheet2的汇总结果写入“对账单”表的A列和C列
Sub Reconciliation() Dim dict As Object Dim arr As Variant, brr As Variant Dim i As Long Dim category As String Dim amount As Double Dim Key As Variant ' 创建字典对象 Set dict = CreateObject("Scripting.Dictionary") ' 读取表一的数据到数组 arr = Sheets("Sheet1").Range("A1").CurrentRegion ' 按照订单号和金额分类汇总表一的数据 For i = 2 To UBound(arr) category = "'" & arr(i, 1) ' 获取订单号，加引号转成文本格式 amount = arr(i, 2) ' 获取金额 dict(category) = dict(category) + amount ' 分类汇总金额 Next i ' 将汇总数据写入对账单表格的A列和B列 Sheets("对账单").Range("A2").Resize(dict.Count) = WorksheetFunction.Transpose(dict.Keys) Sheets("对账单").Range("B2").Resize(dict.Count) = WorksheetFunction.Transpose(dict.Items) ' 清空字典中的值但保留键 For Each Key In dict.Keys dict(Key) = 0 ' 将值重置为0 Next Key ' 读取表二的数据到数组 brr = Sheets("Sheet2").Range("A1").CurrentRegion.Value ' 将表二的金额加到字典中 For i = 2 To UBound(brr) category = "'" & brr(i, 1) ' 获取订单号 amount = brr(i, 2) ' 获取金额 dict(category) = dict(category) + amount ' 分类汇总金额 Next i ' 将汇总数据写入对账单表格的A列和C列 Sheets("对账单").Range("A2").Resize(dict.Count) = WorksheetFunction.Transpose(dict.Keys) Sheets("对账单").Range("C2").Resize(dict.Count) = WorksheetFunction.Transpose(dict.Items) MsgBox "对账单生成完毕" End Sub
5.6.9 多条件汇总
- 示例：对指定区域数据，按照产品名称对等级、数量和金额进行汇总，并将结果写入新的区域中。这样，可以方便地查看每种产品的总数量和总金额，以及所有等级
- 步骤：
- 读取数据：将当前工作表的A1单元格开始的区域数据读取到数组arr中
- 初始化计数器：初始化h为0，用于记录唯一产品名称的索引
- 循环遍历数据：从第2行开始遍历数组arr（假设第1行为标题），检查字典中是否存在当前产品名称
- 如果存在，获取该产品的索引t，累加等级、数量和金额
- 如果不存在，增加h的值，将产品名称及其索引存入字典，并将产品的详细信息存入数组brr
- 将汇总后的结果写入工作表，从F2单元格开始
- 示例图：
来源于吴稳嘉老师的VBA入门教程 Sub AggregateData() ' 声明变量 Dim d As New Dictionary Dim brr(1 To 10000, 1 To 4) As Variant Dim arr As Variant Dim i As Long, t As Long, h As Long ' 将A1开始的当前区域数据加载到数组arr arr = Range("A1").CurrentRegion.Value ' 初始化h，用于记录唯一产品名称的索引 h = 0 ' 循环遍历arr数组，从第2行开始（假设第1行为标题） For i = 2 To UBound(arr, 1) ' 检查字典中是否存在当前产品名称 If d.Exists(arr(i, 1)) Then ' 如果存在，获取该产品的索引t t = d(arr(i, 1)) ' 累加等级，使用顿号连接 brr(t, 2) = brr(t, 2) & "、" & arr(i, 2) ' 累加数量 brr(t, 3) = brr(t, 3) + arr(i, 3) ' 累加金额 brr(t, 4) = brr(t, 4) + arr(i, 4) Else ' 如果不存在，增加h的值 h = h + 1 ' 将产品名称和索引存入字典 d(arr(i, 1)) = h ' 将产品名称、等级、数量和金额存入brr数组 brr(h, 1) = arr(i, 1) brr(h, 2) = arr(i, 2) brr(h, 3) = arr(i, 3) brr(h, 4) = arr(i, 4) End If Next i ' 将汇总结果写入F2开始的区域 Range("F2").Resize(h, 4).Value = brr End Sub
扫一扫
8122
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
