VBA高级集合：可以读取、修改键值的集合

本文介绍了一个VBA的高级集合类（AdvCollection），扩展了Collection对象的功能，包括添加、删除元素，修改元素值，重命名键，获取键对应的序号等。提供了详细的语法说明和操作示例。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

VBA的Collection集合对象为我们提供了数组之外的多数据变量操作方法。但是Collection对象仍然存在一定缺陷：即只能进行元素的读取、添加和删除，以及集合元素个数的读取，实际对集合的使用中，我们往往需要更多的操作，如对修改某元素的值、读取或修改某索引对应键值、读取某键值对应的索引号、清空集合以便重新使用等。本程序通过构建高级集合类（AdvCollection），实现集合应具有的全部功能。

Add 方法：添加元素
语法：高级集合变量.add Element,[Key],[Before],[After]
带方括号为可选参数。第一次赋值不得出现Before和After。
第1次赋值以后Before 和After不得同时出现。Element为元素，可以是数值或对象。

Remove方法：删除元素。语法：高级集合变量.Remove IndexorKey。
IndexorKey 可以为整型、整型变体、字符串、字符串变体。

EraseCollection方法：高级集合清零，清零后的高级数组中不再有元素。
语法：高级集合变量.EraseCollection

Element属性：读取元素。默认属性,只读。
语法：变量 = 高级集合变量.Element(IndexorKey) 或变量=高级集合变量(IndexorKey)
返回变体变量
参数Indexorkey数据类型同Remove方法参数。
设置VBA默认属性，可以事先导出类模块（AdvCollection.cls），用记事本打开类模块文件，
在想要设置默认属性的程序内第一句输入：Attribute Element.VB_UserMemId = 0

ChangeValue属性：为元素赋新值。只写。
语法：[set]高级集合变量.ChangeValue(IndexorKey) = newvalue
参数IndexorKey要求同上。
newvalue，新值的变量，数值或对象。如为对象应使用set关键字。

KeyRename属性：修改键名。只写。
语法: 高级集合变量(IndexorKey) = varialbeofkey
参数IndexorKey，序号或旧键名，要求同上。varialbeofkey,新键名，为字符串或字符串变体。
如IndexorKey使用键名，则前后可以重名，相当于未做操作。

KeyofInex属性：读取某序号为Index对应的键名。只读。
语法：变量 = KeyofIndex(Index)
返回字符串型变体变量
参数Index，为整型或整型变体变量。

IndexofKey属性：读取某键名对应的序号。只读。
语法：变量 = IndexofKey(Key)
返回整型变体变量
参数Key，字符串或字符串型变体变量。

参数不得越界使用。遍历高级集合时，不使用for each循环，应使用for i = count1 to count2 循环。

Count属性：返回高级集合元素个数。整型。

语法：变量 = 高级集合变量.count

以下为类模块AdvCollection.cls文件的源代码。

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "AdvCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Base 1
Dim myCollection() As Variant
Dim intCount As Integer
Dim intOldCount As Integer
Dim strKeys() As Variant
Dim myOldCollection As Variant
Dim myOldKeys  As Variant

Sub Add(Element As Variant, Optional Key As Variant, Optional Before As Variant, Optional After As Variant)
    Dim intMyError As Integer
    Dim strK As String
    On Error GoTo Handler
    If Not IsMissing(Before) And Not IsMissing(After) Then '筛除before和after同时存在的情况
        Err.Raise 101 + vbObjectError, "高级集合.AdvCollection.add过程", "变量Before和After不得同时赋值"
    End If
    If intCount = 0 Then
        If Not IsMissing(Before) Or Not IsMissing(After) Then '初始化，剔除before或after存在的情况
            Err.Raise 102 + vbObjectError, "高级集合.AdvCollection.add过程", "集合的第1个元素赋值不得使用Before或Afer"
        End If
    Else
        If Not IsMissing(Before) Then
            If VarType(Before) = vbInteger Then
                If Before > intCount Or Before < 1 Then '筛除before越界
                    Err.Raise 103 + vbObjectError, "高级集合.AdvCollection.add过程", "变量Before值越界"
                End If
            ElseIf VarType(Before) = vbString Then
                If Before = "" Then
                    Err.Raise 104 + vbObjectError, "高级集合.AdvCollection.add过程", "变量Before为键值时不得为空"
                Else
                    Before = WorksheetFunction.Match(Before, myOldKeys, 0)
                    Before = CInt(Before)
                End If
            Else
                Err.Raise 105 + vbObjectError, "高级集合.AdvCollection.add过程", "变量Before数据类型错误"
            End If
        End If
        If Not IsMissing(After) Then
            If VarType(After) = vbInteger Then
                If After > intCount Or After < 1 Then   '删除after越界
                    Err.Raise 103 + vbObjectError, "高级集合.AdvCollection.add过程", "变量After的值越界"
                End If
            ElseIf VarType(After) = vbString Then
                If After = "" Then
                    Err.Raise 104 + vbObjectError, "高级集合.AdvCollection.add过程", "变量After为键值时不得为空"
                Else
                    After = WorksheetFunction.Match(After, myOldKeys, 0)
                    After = CInt(After)
                End If
            Else
                Err.Raise 105 + vbObjectError, "高级集合.AdvCollection.add过程", "变量After数据类型错误"
            End If
        End If
    End If
    intOldCount = intCount
    intCount = intCount + 1
    If intOldCount = 0 Then
        ReDim myCollection(1 To intCount)
        ReDim strKeys(1 To intCount)
        If IsMissing(Key) Then
            If Not IsObject(Element) Then
                myCollection(1) = Element
            Else
                Set myCollection(1) = Element
            End If
            strKeys(1) = ""
        Else
            If VarType(Key) = vbString Then
                If Not IsObject(Element) Then