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)