VBA 的集合和字典的使用

创不了浩

已于 2024-03-22 08:16:36 修改

阅读量4k

点赞数 22

文章标签： java 服务器数据库 excel

于 2024-02-29 11:48:47 首次发布

本文链接：https://blog.csdn.net/qq_41398619/article/details/136366834

版权

VBA Collection

Collection集合
- 不允许重复
- 不允许使用键来添加项
Dictionary字典
- 字典用法
调教ChatGPT
- 修改后

Collection集合

在 VBA 中，Collection 和 Dictionary 都是用来存储和管理数据的对象，但它们之间有一些重要的区别。

Collection：

Collection 是一种基本的对象集合，用于存储项并允许通过索引或关键字访问这些项。
Collection 的项是通过 Add 方法添加的，并且可以通过索引或 Item 方法进行访问。
Collection 的项没有特定的顺序，它们按照添加的顺序存储。
Collection 不支持直接检查键是否存在，需要通过循环遍历集合来查找。
示例：

Sub test()
    Dim col As New Collection
    col.Add "Apple"
    col.Add "Banana"
    col.Add "Orange"
    
    ' 遍历所有项
    Dim item As Variant
    For Each item In col
        Debug.Print item
    Next item
End Sub

不允许重复

以下代码报错：

Dim col As New Collection
col.Add "Apple", "Fruit"
col.Add "Banana", "Fruit"
col.Add "Orange", "Fruit"

' 遍历所有项
Dim item As Variant
For Each item In col
    Debug.Print item
Next item

在这里插入图片描述
调试显示这行报错

Collection不允许有重复元素，修改后猜猜打印什么内容！

Dim col As New Collection
col.Add "Apple", "Fruit1"
col.Add "Banana", "Fruit2"
col.Add "Orange", "Fruit3"

' 遍历所有项
Dim item As Variant
For Each item In col
    Debug.Print item
Next item

在这里插入图片描述

不允许使用键来添加项

在 VBA 中，Collection 对象不支持使用键来添加项。在您的代码中，您尝试为每个项指定了一个键，这是不支持的。Collection 对象只能通过 Add 方法添加项的值，而不能为每个项指定一个键

Dictionary字典

Dictionary：

Dictionary 是一种更灵活的对象集合，用于存储键值对，并允许通过键来访问值。
Dictionary 的项是通过 Add 方法添加的，每个项都有一个键和一个值。
Dictionary的键是不能重复的！！！
Dictionary 的项没有固定的顺序，它们是无序存储的。
Dictionary 支持直接检查键是否存在，使用 Exists 方法来检查键是否存在。

Sub test()
    Dim dict As New Scripting.Dictionary ' 必须引入 "Microsoft Scripting Runtime"
    dict.Add "Apple", "Red"
    dict.Add "Banana", "Yellow"
    dict.Add "Orange", "Orange"
    
    ' 遍历所有项
    Dim key As Variant
    For Each key In dict.Keys
        Debug.Print key & " -> " & dict(key)
    Next key

End Sub

报错：
这个错误通常表示您的代码中缺少对字典对象所需的引用。确保您在 VBA 中已经添加了对 “Microsoft Scripting Runtime” 的引用，方法如下：

打开 Visual Basic 编辑器（在 Excel 中，按下 Alt + F11）。
在菜单栏中，选择 “工具” > “引用”。
在弹出的对话框中找到并选中 “Microsoft Scripting Runtime”。
确保勾选框被选中，然后点击 “确定”。
完成上述步骤后，您的代码应该可以正常工作了。

运行结果：
在这里插入图片描述

注意，只有字典才可以这么使用dict.Keys

为一个键重复添加值是会报错的。
在这里插入图片描述

字典用法

“呼之即来，挥之即去”
即学会d(a)=s 和 s=d(a) 就差不多了，忘记ADD存在。
一、定义字典
Set d = CreateObject(“Scripting.Dictionary”)

二、呼之即来，挥之即去

d("张三“)=1 '相当于给字典赋值，张三过来（没有就生成）拿个1站一边去
d("李四”)=2 '相当于给字典赋值，李四过来（没有就生成）拿个2站一边去
d("李四”)=3 '相当于改变值，字典中已经有李四了，李四跑过来，丢下2换个3站一边去
注：这时字典中有两个人的存在，张三＝1 和李四＝3，相当于实现了去重复的功能

s=d(“张三”) 's=1 即叫了声张三，张三就告诉你他拿的是1
s=d(“李四”) 's=3 即叫了声李四，李四就告诉你他拿的是3
s=d(“麻子”) 's=“” 没有找到麻子怎么办呢，字典里就自动生成一个麻子d(“麻子”) ＝“”，告诉你他手上是空的
注：这时字典中有三个人的存在，张三＝1 ; 李四＝3;麻子＝“”
三、将字典里的东西变成数组
arr= d.Keys '把名字的集合按先来后到的原则放到一维数组里 arr(0)＝“张三” ; arr(1)＝“李四” ; arr(2)＝“麻子”
arr1=d.Items '把名字对应的值的集合按先来后到的原则放到一维数组里 arr1(0)＝“1” ; arr1(1)＝“3” ; arr1(2)＝“”

四、查找字典中有没有这个人
s=d.Exists(“张三”) 's=True 有的
s=d.Exists(“彭希遴”) 's=False 没有
五、清空数组
d.RemoveAll

调教ChatGPT

你开始给我的代码思路是错的，我需要记录键值对信息，但是你让我使用 Dim mapping As New Collection，Collection没有这个存储键值对的功能，所以这句话也是有问题的，mapping.Add wsName, transformedName。并且打印的时候mapping也没有keys的属性，所以问题很多。我需要你优化代码，将mapping定义为字典，对应的添加键值对和打印键值对的信息都给我修改。

Sub ProcessSheets()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim mapping As New Collection
    Dim wsName As String
    Dim transformedName As String

    ' 打开选定的工作簿
    ' Set wb = Workbooks.Open(filePath)
    
    ' 打开目标工作簿
    Dim filePath As Variant
    filePath = "C:\Users\Administrator\Desktop\VB\LC167-P1.xlsx" ' 设置工作簿路径
    On Error Resume Next
    Set wb = Workbooks.Open(filePath, ReadOnly:=True)
    On Error GoTo 0
    
    ' 检查工作簿是否成功打开
    If wb Is Nothing Then
        MsgBox "无法打开工作簿。", vbExclamation
        Exit Sub
    End If
    
    ' 遍历工作簿中的每个工作表
    For Each ws In wb.Worksheets
        wsName = ws.Name
        ' 检查工作表名中是否包含 "-"
        If InStr(wsName, "-") > 0 Then
            ' 转换工作表名格式
            transformedName = Replace(ws.Name, "-", "/")
            transformedName = StripNonNumeric(transformedName)
            ' 添加映射关系到 Collection 中
            mapping.Add wsName, transformedName
        End If
    Next ws
    
    ' 打印映射关系
    Dim key As Variant
    For Each key In mapping.Keys
        Debug.Print key & " -> " & mapping(key)
    Next key

    
    ' 关闭工作簿
    wb.Close SaveChanges:=False
End Sub

' Mid(string, start, length):Mid(sheetName, i, 1) 表示从字符串 sheetName 中提取从位置 i 开始的一个字符。
Function StripNonNumeric(ByVal inputString As String) As String
    Dim result As String
    Dim i As Integer
    For i = 1 To Len(inputString)
        If IsNumeric(Mid(inputString, i, 1)) Or Mid(inputString, i, 1) = "/" Then
            result = result & Mid(inputString, i, 1)
        End If
    Next i
    StripNonNumeric = result
End Function

修改后

Sub ProcessSheets()
    Dim wb As Workbook
    Dim ws As Worksheet
    'Dim mapping As New Collection
    Dim mapping As New Scripting.Dictionary ' 使用字典对象存储键值对
    Dim wsName As String
    Dim transformedName As String

    ' 打开文件对话框并选择工作簿文件
    ' With Application.FileDialog(msoFileDialogFilePicker)
    '     .AllowMultiSelect = False
    '     .Title = "选择要打开的工作簿"
    '     .Filters.Clear
    '     .Filters.Add "Excel 文件", "*.xlsx,*.xlsm,*.xls"
    '     If .Show = -1 Then
    '         filePath = .SelectedItems(1)
    '     Else
    '         MsgBox "没有选择文件。", vbExclamation
    '         Exit Sub
    '     End If
    ' End With

    ' 打开选定的工作簿
    ' Set wb = Workbooks.Open(filePath)
    
    ' 打开目标工作簿
    Dim filePath As Variant
    filePath = "C:\Users\Administrator\Desktop\VB\LC167-P1.xlsx" ' 设置工作簿路径
    On Error Resume Next
    Set wb = Workbooks.Open(filePath, ReadOnly:=True)
    On Error GoTo 0
    
    ' 检查工作簿是否成功打开
    If wb Is Nothing Then
        MsgBox "无法打开工作簿。", vbExclamation
        Exit Sub
    End If
    
    ' 遍历工作簿中的每个工作表
    For Each ws In wb.Worksheets
        wsName = ws.Name
        ' 检查工作表名中是否包含 "-"
        If InStr(wsName, "-") > 0 Then
            ' 转换工作表名格式
            transformedName = Replace(ws.Name, "-", "/")
            transformedName = StripNonNumeric(transformedName)
            ' 添加映射关系到 Collection 中
            ' mapping.Add wsName, transformedName

            ' 检查工作表名和转换后的名称是否有效，如果无效则跳过该工作表
            If wsName <> "" And transformedName <> "" Then
                ' 添加映射关系到 Collection 中
                On Error Resume Next
                mapping.Add wsName, transformedName
                On Error GoTo 0
                
                ' 检查是否成功添加映射关系
                If Err.Number <> 0 Then
                    MsgBox "无法添加映射关系：" & wsName & " -> " & transformedName, vbExclamation
                    Err.Clear
                End If
            Else
                MsgBox "无效的工作表名或转换后的名称：" & wsName & " -> " & transformedName, vbExclamation
            End If


        End If
    Next ws
    
    ' 检查映射关系集合是否为空
    If mapping.Count > 0 Then
        ' 打印映射关系
        Dim key As Variant
        For Each key In mapping.Keys
            Debug.Print key & " -> " & mapping(key)
        Next key
    Else
        Debug.Print "映射关系集合为空。"
    End If


    
    ' 关闭工作簿
    wb.Close SaveChanges:=False
End Sub

' Mid(string, start, length):Mid(sheetName, i, 1) 表示从字符串 sheetName 中提取从位置 i 开始的一个字符。
Function StripNonNumeric(ByVal inputString As String) As String
    Dim result As String
    Dim i As Integer
    For i = 1 To Len(inputString)
        If IsNumeric(Mid(inputString, i, 1)) Or Mid(inputString, i, 1) = "/" Then
            result = result & Mid(inputString, i, 1)
        End If
    Next i
    StripNonNumeric = result
End Function