标签：VBA，ArrayList，Queue，Sortedlist，Stack，Random
在VBA中，ArrayList与内置的Collection对象类似，但提供了更丰富的功能，详细介绍参见：
Excel VBA解读（156）： 数据结构—ArrayList
Excel VBA解读（157）： 数据结构—ArrayList（续）
下面再介绍几个相关代码示例，以加深对ArrayList等相关方法的认识。
代码1：基本操作
代码语言：javascript复制Sub testArrayList()
'创建并填充ArrayList
Dim myArrayList As Object
Dim myArrayList2 As Object
Dim xItem
Dim myrange
Set myArrayList = CreateObject("System.Collections.ArrayList")
myArrayList.Add "完美Excel"
myArrayList.Add "123"
myArrayList.Add "C"
myArrayList.Add "Excel"
myArrayList.Add "excelperfect"
'打印结果
Debug.Print Join(myArrayList.toarray(), Chr(10))
'复制 ArrayList
Set myArrayList2 = myArrayList.Clone
'添加元素并排序ArrayList
'对ArrayList添加一个新元素
myArrayList.Add "Z"
'对ArrayList移除一个元素
myArrayList.Remove "C"
'打印结果
Debug.Print Join(myArrayList.toarray(), Chr(10))
'打印结果
Debug.Print "含有C的列表 " & myArrayList.Contains("C")
Debug.Print "含有Z的列表 " & myArrayList.Contains("Z")
'打印结果 - 统计元素和容量
Debug.Print "大小: " & myArrayList.Count
Debug.Print "容量: " & myArrayList.Capacity
'去掉ArrayList中的空元素
myArrayList.TrimToSize
'打印结果 - 统计元素和容量
Debug.Print "大小: " & myArrayList.Count
Debug.Print "容量: " & myArrayList.Capacity
'排序ArrayList
myArrayList.Sort
'打印结果
Debug.Print Join(myArrayList.toarray(), Chr(10))
'反转ArrayList
myArrayList.Reverse
'打印结果
Debug.Print Join(myArrayList.toarray(), Chr(10))
'打印复制ArrayList2结果
Debug.Print Join(myArrayList2.toarray(), Chr(10))
'toarray转换ArrayList到工作表
Range("B1").Resize(myArrayList.Count) = Application.Transpose(myArrayList.toarray())
Range("C1").Resize(1, myArrayList.Count) = myArrayList.toarray()
Set myArrayList = Nothing
Set myArrayList2 = Nothing
End Sub代码2：测试ArrayList
代码语言：javascript复制Sub Collections_ArrayList()
'需要引用库mscorlib
Dim ArrayListOne As Object
Dim ArrayListTwo As ArrayList
Dim ArrayListThree As Object
Dim ArrayListFour As ArrayList
Set ArrayListOne = CreateObject("System.Collections.ArrayList")
Set ArrayListTwo = New ArrayList
Set ArrayListThree = CreateObject("System.Collections.ArrayList")
Set ArrayListFour = New ArrayList
ArrayListOne.Add "A"
ArrayListOne.Add "B"
ArrayListOne.Add "D"
ArrayListOne.Insert 2, "C"
ArrayListOne.Insert 2, "C"
ArrayListOne.Add "E"
ArrayListOne.Add "C"
ArrayListOne.Add "F"
ArrayListOne.Add "G"
Debug.Print ArrayListOne.Item(3)
Debug.Print ArrayListOne.Contains("C")
Debug.Print ArrayListOne.IndexOf_2("C", 0, 4)
Debug.Print ArrayListOne.Contains("H")
Debug.Print ArrayListOne.LastIndexOf("C")
ArrayListOne.Remove "C"
ArrayListOne.RemoveAt 5
With ArrayListTwo
.Add "1"
.Add "2"
.Add "3"
.Add "4"
.Add "5"
End With
ArrayListThree.Add "EE"
ArrayListThree.Add "CC"
ArrayListThree.Add "BB"
ArrayListThree.Insert 2, "DD"
ArrayListThree.Add "AA"
ArrayListOne.Addrange ArrayListThree
ArrayListOne.insertRange 6, ArrayListTwo
ArrayListOne.Addrange ArrayListTwo
ArrayListOne.RemoveRange 6, 5
ArrayListOne.Reverse_2 7, 5
ArrayListOne.TrimToSize
Debug.Print Join(ArrayListOne.toarray(), Chr(10))
Debug.Print ArrayListOne.ToString
Range("A10").Resize(ArrayListOne.Capacity) = Application.Transpose(ArrayListOne.toarray())
Range("C10").Resize(, ArrayListOne.Count) = ArrayListOne.toarray()
With ArrayListOne
Debug.Print
.binarysearch_2("CC")
.Sort
Debug.Print .binarysearch_2("CC")
.Reverse
Debug.Print Join(.toarray(), Chr(10))
Debug.Print .GetHashCode
End With
Debug.Print Join(ArrayListFour.toarray(), Chr(10))
ArrayListFour.Add "Excel"
ArrayListFour.Add "完美Excel"
ArrayListFour.Add "my123"
ArrayListFour.Add "Python"
ArrayListOne.SetRange 5, ArrayListFour
Debug.Print Join(ArrayListOne.toarray(), Chr(10))
Set ArrayListOne = Nothing
Set ArrayListTwo = Nothing
Set ArrayListThree = Nothing
Set ArrayListFour = Nothing
End Sub代码3：测试ArrayList
代码语言：javascript复制Sub myTest()
Dim InputArray
InputArray = Array("a", "b", "c", "1", "2", "3", "D", "1", "i", "ii", "iii", "2", "i", "ii")
Dim ArrayTwo()
Dim myArrayList As Object
Dim ArrayItem As Long
Dim LevelOne As String
Dim LevelTwo As String
Dim LevelThree As String
Set myArrayList = CreateObject("System.Collections.ArrayList")
For ArrayItem = LBound(InputArray) To UBound(InputArray)
If Not IsNumeric(InputArray(ArrayItem)) And Left(InputArray(ArrayItem), 1) <> "i" Then
LevelOne = InputArray(ArrayItem)
LevelTwo = vbNullString
LevelThree = vbNullString
ElseIf
IsNumeric(InputArray(ArrayItem)) Then
myArrayList.Remove InputArray(ArrayItem - 1)
LevelTwo = InputArray(ArrayItem)
LevelThree = vbNullString
Else
LevelThree = InputArray(ArrayItem)
End If
myArrayList.Add LevelOne & LevelTwo & LevelThree
Next ArrayItem
ReDim ArrayTwo(1 To myArrayList.Count)
ArrayTwo() = myArrayList.toarray()
For ArrayItem = LBound(ArrayTwo) To UBound(ArrayTwo)
' For ArrayItem = 0 To myArrayList.Count - 1
' ArrayTwo(ArrayItem 1) = myArrayList(ArrayItem)
Debug.Print ArrayTwo(ArrayItem)
Next
Set myArrayList = Nothing
End Sub代码4：测试ArrayList
代码语言：javascript复制Sub testArray()
Dim x As Long, eList, eItems
Dim mySourceList As Object
Set mySourceList = CreateObject("System.Collections.ArrayList")
mySourceList.Add "three"
mySourceList.Add "napping"
mySourceList.Add "cats"
mySourceList.Add "in"
mySourceList.Add "the"
mySourceList.Add "barn"
Dim myTargetArray(10) As String
myTargetArray(0) = "The"
myTargetArray(1) = "quick"
myTargetArray(2) = "brown"
myTargetArray(3) = "fox"
myTargetArray(4) = "jumped"
myTargetArray(5) = "over"
myTargetArray(6) = "the"
myTargetArray(7) = "lazy"
myTargetArray(8) = "dog"
For x = LBound(myTargetArray) To UBound(myTargetArray)
Debug.Print myTargetArray(x)
Next x
myTargetArray(2) = mySourceList.toarray()(2)
For x = LBound(myTargetArray) To UBound(myTargetArray)
Debug.Print myTargetArray(x)
Next x
Set eList = mySourceList.GetRange(2, 4)
For Each eItems In eList
Debug.Print "List Items= " & eItems
Next
End Sub代码5：测试ArrayList
代码语言：javascript复制Sub testArrayList()
Dim MasterDataList As Object
Dim DataListOne As Object
Dim DatalistTwo As Object
Dim xItem
Set MasterDataList = CreateObject("System.Collections.ArrayList")
Set DataListOne = CreateObject("System.Collections.ArrayList")
Set DatalistTwo = CreateObject("System.Collections.ArrayList")
DataListOne.Add Split("a, b, c", ",")
DataListOne.Add Split("D E F")
DataListOne.Add Split("I, J, K", ",")
DatalistTwo.Add Array("1", "2", "3")
DatalistTwo.Add Array("4", "5", "6")
DatalistTwo.Add Array("7", "8", "9")
For Each xItem In DataListOne
MsgBox xItem(2)
MsgBox DataListOne(0)(0)
Next xItem
For Each xItem In DataListOne
MsgBox Join(xItem)
Next
For Each xItem In DatalistTwo
MsgBox Join(xItem)
Next
MasterDataList.Add DataListOne
MasterDataList.Add DatalistTwo
MsgBox MasterDataList(0)(1)(1)
MsgBox MasterDataList(1)(1)(1)
End Sub代码6：测试Sortedlist
代码语言：javascript复制Sub testSortedlist()
Dim objSortedList As Object
Dim objList2 As Object
Dim i As Integer
Set objSortedList = CreateObject("System.Collections.Sortedlist")
objSortedList.Add "First", "AAAA"
objSortedList.Add "Second", "!"
objSortedList.Add "Third", "CCCC"
objSortedList.Add "Fourth", ","
Debug.Print objSortedList.IndexOfKey("First")
Debug.Print objSortedList.IndexOfValue("AAAA")
Debug.Print objSortedList.IndexOfKey("Second")
Debug.Print objSortedList.IndexOfValue("!")
Debug.Print objSortedList.IndexOfKey("Third")
Debug.Print objSortedList.IndexOfValue("CCCC")
Debug.Print objSortedList.IndexOfKey("Fourth")
Debug.Print objSortedList.IndexOfValue(",")
For i = 0 To objSortedList.Count - 1
Debug.Print objSortedList.GetKey(i) & vbTab & objSortedList.GetByIndex(i)
Next
'结果输出为:
'First Hello
'Fourth !
'Second ,
'Third CCCC
'注意列表是如何按键自动排序的；不可能按值对列表进行排序.
'与ArrayLists相似, SortedLists有Count和Capacity属性, 以及TrimToSize方法.
Debug.Print "大小 : " & objSortedList.Count
Debug.Print "容量 : " & objSortedList.Capacity
objSortedList.TrimToSize
Debug.Print "大小 : " & objSortedList.Count
Debug.Print "容量 : " & objSortedList.Capacity
'结果输出为：
'大小 : 4
'容量 : 16
'大小 : 4
'容量 : 4
'复制SortedList很简单:
Dim xxxx
Set objList2 = objSortedList.Clone
Debug.Print "已排序的列表Key(1) = " & objSortedList.GetKey(1)
Debug.Print "已复制的列表Key(1) = " & objList2.GetKey(1)
'结果:
'已排序的列表Key(1) = Fourth
'已复制的列表Key(1) = Fourth
Set objList2 = Nothing
Set objSortedList = Nothing
End Sub代码7：队列操作
代码语言：javascript复制Sub Queuelist()
With CreateObject("System.Collections.Queue")
.Enqueue "完美Excel"
.Enqueue "123"
.Enqueue "Excel"
.Enqueue "excelperfect"
.Enqueue "Python"
Debug.Print Join(.Toarray(), Chr(10))
.Dequeue
Debug.Print .Peek
Debug.Print Join(.Toarray(), Chr(10))
Range("A1").Resize(.Count) = Application.Transpose(.Toarray())
Range("C1").Resize(1, .Count) = .Toarray()
End With
End Sub代码8：测试Stack
代码语言：javascript复制Sub testStacklist()
With CreateObject("System.Collections.Stack")
.Push "完美Excel"
.Push "123"
.Push "Excel"
.Push "Excelperfect"
.Push "Python"
Debug.Print Join(.Toarray(), Chr(10))
.Pop
Debug.Print .Peek
Debug.Print Join(.Toarray(), Chr(10))
Range("A1").Resize(.Count) = Application.Transpose(.Toarray())
Range("C1").Resize(1, .Count) = .Toarray()
End With
End Sub代码9：随机数
代码语言：javascript复制Sub testRandoms()
Dim fixedRands As Object
Dim strMsg As String
Dim i As Integer
Set fixedRands = CreateObject("System.Random")
'10位数组成的随机数:"
For i = 0 To 5
strMsg = strMsg & " " & fixedRands.Next
Next
strMsg = strMsg & vbCrLf & "5-10之间的随机数:"
For i = 0 To 5
strMsg = strMsg & " " & fixedRands.Next_2(5, 10)
Next
strMsg = strMsg & vbCrLf & "20以内的随机数:"
For i = 0 To 5
strMsg = strMsg & " " & fixedRands.Next_3(20)
Next
strMsg = strMsg & vbCrLf & "双精度小数随机数:"
For i = 0 To 5
strMsg = strMsg & " " & fixedRands.Nextdouble
Next
MsgBox strMsg
Set fixedRands = Nothing
End Sub代码有点多，不过值得一段一段测试，在测试过程中一点一点理解。
