A Simple List Class for VBA Projects

Stefan Huy

Rate me:

4.90/5 (7 votes)

16 Dec 2013CPOL1 min read

64K

For those who badly miss a .NET like List in VBA

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:

VB.NET

Private mList() As Variant
Private mError As Error
Private mDisposed As Boolean

'==============================
'Constructor
'==============================
Public Sub Initialize()
    Disposed = False
End Sub

Public Function CreateInstance() As vbaList
    Dim oNew As New vbaList
    oNew.Initialize
    Set CreateInstance = oNew
End Function

'==============================
'Properties
'==============================
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 Methods
'==============================

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 Methods
'==============================

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