Introduction
This VBA class code implements a .NET like object List
(List<T>
) to your VBA project to avoid the unhandy usage of a VBA Array. Please excuse my bad English, hopefully most of the things are understandable. :)
Background
Sometimes, I need to change some old Excel VBA projects and badly miss a list implementation as I need to handle everything in arrays. So I decided to write my own list class where I've implemented most of the methods and properties of the .NET List
. Simply copy the code to your VBA project as a class. Later on, I will try to add some explanation to the code itself.
Using the Code
To simulate a List
, I decided to use the standard VBA Array
and the data type variant
so it will be possible to add any data type to the Array
. I still get some problems when using the Sort
method, however I hope to find some time to add the sorting feature to the Array
.
Right now, the following properties and methods/functions are implemented:
Properties
Count()
Disposed()
GotError()
ListError()
ListItems()
Methods
Add(ByRef vItem As Variant, Optional index As Long)
Clear()
Contains(ByRef vItem As Variant)
Copy()
Exists(vItem As Variant)
Find(ByRef vItem As Variant)
Dispose()
IndexOf(ByRef vItem As Variant)
LastIndexOf(ByRef vItem As Variant)
Remove()
RemoveAll()
RemoveAtIndex(ByRef index As Long)
ResetError()
Reverse()
Sort()
ToArray()
Copy the code to a new VBA class. The class name must be VbaList
! If you like to change the name, please don't forget to change the references in the class code as well.
Here is the complete class code:
Private mList() As Variant
Private mError As Error
Private mDisposed As Boolean
Public Sub Initialize()
Disposed = False
End Sub
Public Function CreateInstance() As vbaList
Dim oNew As New vbaList
oNew.Initialize
Set CreateInstance = oNew
End Function
Public Property Get Items(ByRef index As Long) As Variant
Items = GetItemAtIndex(index)
End Property
Public Property Get Count() As Long
Count = GetListCount()
End Property
Public Property Get GotError() As Boolean
If ListError Is Nothing Then GotError = False Else GotError = True
End Property
Public Property Get ListItems() As Variant()
ClearError
On Error GoTo Err
ListItems = mList
Exit Property
Err:
ListError = Err
End Property
Public Property Get ListError() As Error
ListError = mError
End Property
Private Property Let ListError(ByRef vError As Error)
Set mError = vError
End Property
Public Property Get Disposed() As Boolean
Disposed = mDisposed
End Property
Private Property Let Disposed(ByRef vValue As Boolean)
mDisposed = vValue
End Property
Public Property Get ToArray()
ToArray = mList
End Property
Public Sub Remove(ByRef vItem As Variant)
DeleteElement (vItem)
End Sub
Public Sub RemoveAtIndex(ByRef index As Long)
DeleteElementAt (index)
End Sub
Public Sub Sort()
BubbleSort (mList)
End Sub
Public Sub Clear()
Erase mList
End Sub
Public Function Find(ByRef vItem As Variant) As Long
Find = FindItem(vItem)
End Function
Public Sub Dispose()
ResetError
Clear
Disposed = True
End Sub
Public Sub ResetError()
ClearError
End Sub
Public Function LastIndexOf(ByRef vItem As Variant)
LastIndexOf = GetLastIndexOf(vItem)
End Function
Public Function IndexOf(ByRef vItem As Variant)
IndexOf = FindItem(vItem)
End Function
Public Sub Reverse()
ReverseList
End Sub
Public Function Exists(vItem As Variant)
Exists = ItemExists(vItem)
End Function
Public Sub Add(ByRef vItem As Variant, Optional index As Long)
If index > 0 Then
AddItemAt index, vItem
Else
AddItem vItem
End If
End Sub
Public Function Contains(ByRef vItem As Variant)
Contains = Exists(vItem)
End Function
Public Function Copy() As vbaList
Set Copy = GetCopy
End Function
Public Sub RemoveAll()
Clear
End Sub
Private Sub ClearError()
Set mError = Nothing
End Sub
Private Function GetListCount() As Long
ClearError
On Error GoTo Err
GetListCount = UBound(mList) - LBound(mList) + 1
Exit Function
Err:
GetListCount = 0
End Function
Private Function GetItemAtIndex(ByRef index As Long) As Variant
ClearError
On Error GoTo Err
GetItemAtIndex = mList(index)
Exit Function
Err:
ListError = Err
GetItemAtIndex = Nothing
End Function
Private Sub AddItemAt(index As Long, vItem As Variant)
ClearError
On Error GoTo Err
Dim ar() As Variant
Dim i As Integer
i = Count
ReDim ar(i)
For a = 0 To index - 1
ar(a) = mList(a)
Next
ar(index) = vItem
For a = index + 1 To i
ar(a) = mList(a - 1)
Next
mList = ar
Exit Sub
Err:
ListError = Err
End Sub
Private Sub BubbleSort(ByVal vArray As Variant)
ClearError
On Error GoTo Err
Dim i As Long
Dim iMin As Long
Dim iMax As Long
Dim vSwap As Variant
Dim swapped As Boolean
iMin = LBound(vArray)
iMax = UBound(vArray) - 1
Do
swapped = False
For i = iMin To iMax
If vArray(i) > vArray(i + 1) Then
vSwap = vArray(i)
vArray(i) = vArray(i + 1)
vArray(i + 1) = vSwap
swapped = True
End If
Next
iMax = iMax - 1
Loop Until Not swapped
mList = vArray
Erase vArray
Exit Sub
Err:
ListError = Err
End Sub
Private Sub DeleteElementAt(index As Integer)
ClearError
On Error GoTo Err
Dim i As Integer
For i = index + 1 To Count - 1
mList(i - 1) = mList(i)
Next
ReDim Preserve mList(Count - 2)
Exit Sub
Err:
ListError = Err
End Sub
Private Sub DeleteElement(ByRef vItem As Variant)
ClearError
On Error GoTo Err
DeleteElementAt (FindItem(vItem))
Exit Sub
Err:
ListError = Err
End Sub
Private Sub AddItem(vItem As Variant)
ClearError
On Error GoTo Err
Dim i As Long
i = Count
ReDim Preserve mList(i)
mList(i) = vItem
Exit Sub
Err:
ListError = Err
End Sub
Private Function FindItem(vItem As Variant) As Long
ClearError
On Error GoTo Err
FindItem = -1
For i = 0 To Count - 1
If mList(i) = vItem Then
FindItem = i
Exit For
End If
Next i
Exit Function
Err:
ListError = Err
FindItem = -1
End Function
Private Function GetLastIndexOf(vItem As Variant) As Long
ClearError
On Error GoTo Err
GetLastIndexOf = -1
Dim i As Long
For i = Count - 1 To 0 Step -1
If mList(i) = vItem Then
GetLastIndexOf = i
Exit Function
End If
Next i
Exit Function
Err:
ListError = Err
GetLastIndexOf = -1
End Function
Private Sub ReverseList()
ClearError
On Error GoTo Err
Dim ar() As Variant
Dim i As Long
Dim j As Long
If Count = 0 Then Exit Sub
i = Count - 1
j = i
ReDim ar(i)
For a = 0 To i
ar(a) = mList(j)
j = j - 1
Next a
mList = ar
Erase ar
Exit Sub
Err:
ListError = Err
End Sub
Private Function ItemExists(vItem As Variant) As Boolean
If FindItem(vItem) > -1 Then
ItemExists = True
Else
ItemExists = False
End If
End Function
Private Function GetCopy() As vbaList
Dim list As New vbaList
Set list = list.CreateInstance
For i = 0 To Count - 1
list.Add mList(i)
Next i
Set GetCopy = list
i = GetCopy.Count
End Function
Here is a small example. For testing, copy the code to a VBA module:
Sub test()
Dim list As New vbaList
Set list = list.CreateInstance
list.Add 1
list.Add 9
list.Add 6
list.Add 13
list.Add 2
list.Add 6
list.Add 4, 3
list.Remove 13
list.RemoveAtIndex 2
list.Add "Test 1"
list.Add "Test 2"
list.Add 6
Dim listCopy As New vbaList
Set listCopy = list.Copy
Dim i As Long
Debug.Print "========================================"
Debug.Print "IndexOf Pos: " & list.IndexOf(6)
Debug.Print "LastIndexOf Pos: " & list.LastIndexOf(6)
Debug.Print "Find Test 1 @ Pos: " & list.Find("Test 1")
Debug.Print "[Test 1] exists: " & list.Exists("Test 1")
Debug.Print "[Test 3] exists: " & list.Exists("Test 3")
Debug.Print "Count: " & list.Count
list.Clear
Debug.Print "Clear() Count: " & list.Count
list.Dispose
Debug.Print "Disposed: " & list.Disposed
Debug.Print ""
For i = 0 To listCopy.Count - 1
Debug.Print "Default - Pos " & i & ": " & listCopy.Items(i)
Next i
listCopy.Reverse
For i = 0 To listCopy.Count - 1
Debug.Print "Reverse - Pos " & i & ": " & listCopy.Items(i)
Next i
End Sub