IndexedArray Class: Uses a Dictionary Keys to Index a 2 Dimensional Array of Values

Question

This class encapsulates a 2D Array and a Scripting Dictionary. Values are add or returned from to the Array using a Key and a ColumnIndex, e.g. IndexedArray(Key, ColumnIndex) = Value . The Key is used to get the RowIndex of the Array. The Value is then added to the Array, e.g. Array(ColumnIndex, RowIndex).

Although, I am quite pleased with the performance, flexibility, and ease of use, I am open to any suggestions on how to improve its design.

IndexedArray:Class

Attribute VB_Description = "Uses a Scripting.Dictionary (m.Dictionary) to Index and Array of Values"
Option Explicit
Private Const DEFAULT_ROW_BUFFER As Long = 100
Attribute DEFAULT_ROW_BUFFER.VB_VarDescription = "The number of rows added to m.Values when resized"
Private Const DEFAULT_COLUMN_COUNT As Long = 10
Attribute DEFAULT_COLUMN_COUNT.VB_VarDescription = "The default number of Columns in m.Values"
Private Type Members
 ColumnCount As Long
 Dictionary As Object
 Initiated As Boolean
 Values As Variant 'Values(Columns, Rows)
End Type
Private m As Members
Attribute m.VB_VarDescription = "Encapsulates Class Member Fields For VBA Like m Reference (e.g. m.Value is simular to VBA m_Value)"
Private Sub Class_Initialize()
 Set m.Dictionary = CreateObject("Scripting.Dictionary")
 m.ColumnCount = DEFAULT_COLUMN_COUNT
 ReDim m.Values(1 To m.ColumnCount, 1 To DEFAULT_ROW_BUFFER)
End Sub
Public Property Get Value(ByVal Key As Variant, ByVal ColumnIndex As Long) As Variant
Attribute Value.VB_Description = "Gets or sets m.Values() element at Index returned by m.Dictionary(Key)"
Attribute Value.VB_UserMemId = 0
 If Not m.Dictionary.Exists(Key) Then Expand Key
 Value = m.Values(ColumnIndex, m.Dictionary(Key))
End Property
Public Property Let Value(ByVal Key As Variant, ByVal ColumnIndex As Long, ByVal vValue As Variant)
 If Not m.Dictionary.Exists(Key) Then Expand Key
 m.Values(ColumnIndex, m.Dictionary(Key)) = vValue
End Property
Public Function Exists(Key As Variant) As Boolean
Attribute Exists.VB_Description = "Tests if Key Exists in m.Dictionary"
 Exists = m.Dictionary.Exists(Key)
End Function
Private Sub Expand(ByVal Key As Variant)
Attribute Expand.VB_Description = "Adds new Key to m.Dictionary and Increase adds an additional number of rows to m.Values equal to DEFAULT_ROW_BUFFER."
 m.Dictionary.Add Key, m.Dictionary.Count + 1
 If m.Dictionary.Count > UBound(m.Values, 2) Then ReDim Preserve m.Values(1 To m.ColumnCount, 1 To UBound(m.Values, 2) + DEFAULT_ROW_BUFFER)
End Sub
Public Sub setColumnCount(ColumnCount As Long)
Attribute setColumnCount.VB_Description = "Changes the number of column in m.Values()"
 Dim Values As Variant
 Dim c As Long, r As Long
 If ColumnCount < 1 Then Err.Raise Number:=vbObjectError + 513, Description:="ColumnCount can not be less than 1"
 If m.ColumnCount <> ColumnCount Then
 ReDim Values(1 To ColumnCount, UBound(m.Values, 2))
 For r = 1 To UBound(m.Values)
 For c = 1 To IIf(m.ColumnCount < ColumnCount, m.ColumnCount, ColumnCount)
 Values(c, r) = m.Values(c, r)
 Next
 Next
 m.ColumnCount = ColumnCount
 m.Values = Values
 End If
End Sub
Public Sub EnsureCapacity(Capacity As Long)
 If UBound(m.Values, 2) < Capacity Then ReDim Preserve m.Values(1 To m.ColumnCount, 1 To Capacity)
End Sub
Public Function ToArray(Optional SearchString As String, Optional IncludeHeaderRows As Boolean) As Variant()
Attribute ToArray.VB_Description = "Return 2D Array of Values(Rows, Columns) either filtered or unfiltered. Array filtering is delagated to ToFilteredArray"
 Dim Values As Variant
 Dim c As Long, r As Long
 If Len(SearchString) = 0 Then
 ReDim Values(1 To m.Dictionary.Count, 1 To m.ColumnCount)
 For r = 1 To m.Dictionary.Count
 For c = 1 To m.ColumnCount
 Values(r, c) = m.Values(c, r)
 Next
 Next
 ToArray = Values
 Else
 ToArray = ToFilteredArray(SearchString, IncludeHeaderRows)
 End If
End Function
Private Function ToFilteredArray(SearchString As String, IncludeHeaderRows As Boolean) As Variant()
Attribute ToFilteredArray.VB_Description = "Returns a 2D Array of filtered Values(Rows, Columns) to ToArray"
 Dim Key As Variant, header As Variant, Values As Variant
 Dim c As Long, r As Long, n As Long
 With CreateObject("System.Collections.ArrayList")
 If IncludeHeaderRows Then
 header = m.Dictionary.Keys()(0)
 .Add header
 End If
 For Each Key In m.Dictionary.Keys()
 If Key Like SearchString And Not .Contains(Key) Then .Add Key
 Next
 If .Count = 0 Then
 ReDim Values(1 To 1, 1 To 1)
 Values(1, 1) = vbNullString
 Else
 .Sort
 If Not IsEmpty(header) Then
 .Remove header
 .Insert 0, header
 End If
 ReDim Values(1 To .Count + 1, 1 To m.ColumnCount)
 For Each Key In .ToArray
 n = n + 1
 r = m.Dictionary(Key)
 For c = 1 To m.ColumnCount
 Values(n, c) = m.Values(c, r)
 Next
 Next
 End If
 End With
 ToFilteredArray = Values
End Function

Test Routine

Note: constants prefixed with order belong to Public Enum OrderColumns. OrderColumns enumerates all the columns on the Worksheet("Orders").

Public Sub UpdateSummary(KeyColumn As Long, Optional SearchString As String, Optional IncludeHeaderRows As Boolean)
 Dim t As Long
 Application.ScreenUpdating = False
 Dim idxArray As New IndexedArray, Key As Variant, row As Range
 t = Timer
 With ThisWorkbook.Worksheets("Orders")
 Key = "Header Row"
 idxArray(Key, 1) = .Cells(KeyColumn).Value
 idxArray(Key, 2) = "Count"
 idxArray(Key, 3) = "Average"
 idxArray(Key, 4) = .Cells(orderSales).Value
 idxArray(Key, 5) = .Cells(orderQuantity).Value
 idxArray(Key, 6) = .Cells(orderDiscount).Value
 idxArray(Key, 7) = .Cells(orderProfit).Value
 For Each row In .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).EntireRow
 With row
 Key = .Cells(KeyColumn)
 idxArray(Key, 1) = .Cells(KeyColumn).Value
 idxArray(Key, 2) = idxArray(Key, 4) + 1
 idxArray(Key, 3) = "=AVERAGE(RC[-2]:RC[-1])"
 idxArray(Key, 4) = .Cells(orderSales).Value + idxArray(Key, 4)
 idxArray(Key, 5) = .Cells(orderQuantity).Value + idxArray(Key, 5)
 idxArray(Key, 6) = .Cells(orderDiscount).Value + idxArray(Key, 6)
 idxArray(Key, 7) = .Cells(orderProfit).Value + idxArray(Key, 7)
 End With
 Next
 End With
 Debug.Print Round(Timer - t, 2)
 CreateSummaryTable idxArray.ToArray(SearchString, IncludeHeaderRows)
 Application.ScreenUpdating = True
End Sub

Immediate Window Test

UpdateSummary orderCustomer_Name

UpdateSummary orderCustomer_Name

UpdateSummary orderCustomer_Name, "*Alan*", False

UpdateSummary orderCustomer_Name, "*Alan*", False

enter image description here

UpdateSummary orderCustomer_Name, "*Alan*", True

enter image description here

UpdateSummary orderOrder_ID, "*CA-2014-##3###*", True

Download: IndexedArray.xlsm

• Raystafarian: I'd KeyColumn = getKeyColumn If KeyColumn < 1 Or KeyColumn > 18 Then Exit Sub
• QHarr: Slicing with Index does have size limits though I guess you are aware of that?
• Raystafarian: I just meant catch the errors for non-implemented columns, if I put in 0 I get an error and if I put in 100 the table doesn't make any sense. Slice - hm, couldn't you slice off a part of an array into a variant in one shot? I'd imagine you could, but I don't think I know how. Plus I mean - it's not too off the wall to just implement your own index
• TinMan: @Raystafarian I think what I need is a better error message. Excel 16.0 has 16384 columns. Why should I limit the potential of the class? Implementing a Slice function shouldn't be too hard. The main thing that concerns me is getting the syntax right. I want to model it after other languages. So that users will have both an idea of how to use it and be able to look at other documentation and examples on the web, outside of this scope of this class.
• QHarr: You state correctly. And thanks for sharing the above link. I shall bookmark that. I look forward to any future posts you make using what you learn from it! Meanwhile, have a plus +1