VBA 拡張したコレクションの実装例

拡張コレクション（自動ソート機能）

'拡張コレクション（自動ソート機能）
'CollectionEx

Option Explicit

'内部コレクションクラス
Private innerCollection As Collection

'初期化
Private Sub Class_Initialize()
    Set innerCollection = New Collection
End Sub

'要素を追加
Public Sub add(ByRef elm As Object, ByVal key As String)
    'IDが順番通りになるようにインスタンスを追加する
    Dim index As Integer
    For index = 1 To innerCollection.Count
        If elm.id < innerCollection.Item(index).id Then
            Call innerCollection.add(elm, elm.id, index)
            Exit For
        End If
    Next
    
    'ループ内で追加されなかった場合はリストの終端に要素を追加する
    If index > innerCollection.Count Then
        Call innerCollection.add(elm, elm.id)
    End If
End Sub

'全要素を削除
Public Sub Clear()
    Set innerCollection = New Collection
End Sub

'要素数を返す
Public Function Count() As Long
    Count = innerCollection.Count
End Function

'指定番号の要素を返す
Public Function Item(index As Integer) As UserClass
    Item = innerCollection.Item(index)
End Function

'先頭の要素を返す(リストからは要素を削除)
Public Function popHead() As UserClass
    If innerCollection.Count = 0 Then Exit Function

    Set popHead = innerCollection.Item(1)
    innerCollection.Remove (1)
End Function

'終端の要素を返す(リストからは要素を削除)
Public Function popTail() As UserClass
    If innerCollection.Count = 0 Then Exit Function

    Set popTail = innerCollection.Item(innerCollection.Count)
    innerCollection.Remove (innerCollection.Count)
End Function

Userクラス

'UserClass

Option Explicit

'///// メンバ変数 /////
'ユーザーID
Private m_id As String
'ユーザー名
Private m_name As String
'年齢
Private m_age As Integer
'居住地
Private m_address As String

'///// プロパティプロシージャ /////
Property Get id() As String
    id = m_id
End Property

Property Let id(ByVal id As String)
    m_id = id
End Property

Property Get name() As String
    name = m_name
End Property

Property Let name(ByVal name As String)
    m_name = name
End Property

Property Get age() As Integer
    age = m_age
End Property

Property Let age(ByVal age As Integer)
    m_age = age
End Property

Property Get address() As String
    address = m_address
End Property

Property Let address(ByVal address As String)
    m_address = address
End Property

'ユーザーの属性をセットする
Public Sub setAttribute(ByVal id As String, ByVal name As String, ByVal age As Integer, ByVal address As String)
    m_id = id
    m_name = name
    m_age = age
    m_address = address
End Sub

呼び出し側（ActiveXボタンを貼り付けてイベントプロシージャを記述）

'拡張したコレクションの実装例

Option Explicit

Private Sub CommandButton1_Click()
    'ユーザークラスの宣言
    Dim u1 As New UserClass
    Dim u2 As New UserClass
    Dim u3 As New UserClass
    Dim u4 As New UserClass
    Dim u5 As New UserClass
    
    'ユーザーリストの宣言
    Dim userList As New CollectionEx
    
    'ユーザーに属性をセット
    Call u1.setAttribute("1090", "Taro", "20", "Tokyo")
    Call u2.setAttribute("1050", "Hanako", "28", "Osaka")
    Call u3.setAttribute("1010", "Ichiro", "18", "Fukuoka")
    Call u4.setAttribute("1080", "Yoshiko", "25", "Nagoya")
    Call u5.setAttribute("1020", "Kensuke", "15", "Sapporo")
    
    'ユーザーのIDをKEYとしてユーザーリストに追加
    Call userList.add(u1, u1.id)
    Call userList.add(u2, u2.id)
    Call userList.add(u3, u3.id)
    Call userList.add(u4, u4.id)
    Call userList.add(u5, u5.id)
    
    '要素数
    Debug.Print "要素数:" & userList.Count
    
    '先頭から要素を取得し名前を表示する（ID順で表示される）
    Debug.Print userList.popHead.name
    Debug.Print userList.popHead.name
    Debug.Print userList.popHead.name
    Debug.Print userList.popHead.name
    Debug.Print userList.popHead.name
    
    '要素数
    Debug.Print "要素数:" & userList.Count
End Sub