Excel VBA: arrayAppend()

modArrayAppend.bas

' Simulates Collection's append() behaviour by keeping track of the last element's
' index and dynamically expanding the array using quadratic function (to minimize
' in-memory copy actions thus increasing performance significantly). Use this function
' when the number of elements to be appended is unknown.
'
' After all append operations are complete array's size needs to be adjusted to fit
' the contents exactly with ReDim Preserve expression:
'
'     ReDim Preserve arr(LBound(arr) To idx)
'
' After this idx may be reset.
'
' @param arr - dynamic array (can be unallocated or empty)
' @param idx - index of the last current element in arr. Initialize to any value at start.
'              It will be incremented by the append function and passed back by
'              reference. No special actions need to be done to maintain this element's
'              value current - just keep passing it to the append function. It is done
'              this way to keep arrayAppend() stateless (for the price of an extra argument).
' @param val - value to be appended to the array _after_ idx

Sub arrayAppend(arr As Variant, idx As Long, val As Variant)
	Dim size As Long
	If Not isArrayAllocated(arr) Then
		' new un-allocated array - do initial sizing
		ReDim arr(idx To idx)
		arr(idx) = val
	Else
		' existing array
		If idx >= UBound(arr) Then
			size = UBound(arr) - LBound(arr) + 1
			If UBound(arr) + size > idx Then
				' we're over the array's UBound - double the size
				ReDim Preserve arr(LBound(arr) To UBound(arr) + size)
			Else
				' if new index is far forward from the current UBound of the array
				' take a bit of a conservative approach and extend the new array to
				' idx + size
				ReDim Preserve arr(LBound(arr) To UBound(arr) + (idx - UBound(arr)) + size)
			End If
		End If
		idx = idx + 1
		arr(idx) = val
	End If
End Sub

Sub testArrayAppend()

	Dim arr() As String
	Dim idx As Long
	
	' starting with idx = 0
	arrayAppend arr, idx, "a"
	Debug.Assert arr(0) = "a" And LBound(arr) = 0 And UBound(arr) = 0
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 1
	Debug.Assert idx = 0
	arrayAppend arr, idx, "b"
	Debug.Assert arr(0) = "a" And arr(1) = "b"
	Debug.Assert LBound(arr) = 0 And UBound(arr) = 1
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 2
	Debug.Assert idx = 1
	arrayAppend arr, idx, "c"
	Debug.Assert arr(0) = "a" And arr(1) = "b" And arr(2) = "c"
	Debug.Assert LBound(arr) = 0 And UBound(arr) = 3
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 4
	Debug.Assert idx = 2
	arrayAppend arr, idx, "d"
	Debug.Assert arr(0) = "a" And arr(1) = "b" And arr(2) = "c" And arr(3) = "d"
	Debug.Assert LBound(arr) = 0 And UBound(arr) = 3
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 4
	Debug.Assert idx = 3
	arrayAppend arr, idx, "e"
	Debug.Assert arr(0) = "a" And arr(1) = "b" And arr(2) = "c" And arr(3) = "d" And arr(4) = "e"
	Debug.Assert LBound(arr) = 0 And UBound(arr) = 7
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 8
	Debug.Assert idx = 4
	
	' trimming the array
	ReDim Preserve arr(LBound(arr) To idx)
	Debug.Assert arr(0) = "a" And arr(1) = "b" And arr(2) = "c" And arr(3) = "d" And arr(4) = "e"
	Debug.Assert LBound(arr) = 0 And UBound(arr) = 4
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 5
	Debug.Assert idx = 4
	
	' appending value with a gap
	idx = 9
	arrayAppend arr, idx, "f"
	Debug.Assert arr(0) = "a" And arr(1) = "b" And arr(2) = "c" And arr(3) = "d" And arr(4) = "e"
	Debug.Assert arr(5) = "" And arr(9) = "" And arr(10) = "f" And arr(11) = "" And arr(14) = ""
	Debug.Assert LBound(arr) = 0 And UBound(arr) = 14
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 15
	Debug.Assert idx = 10
	
	' trimming the array
	ReDim Preserve arr(LBound(arr) To idx)
	Debug.Assert arr(0) = "a" And arr(1) = "b" And arr(2) = "c" And arr(3) = "d" And arr(4) = "e"
	Debug.Assert arr(5) = "" And arr(9) = "" And arr(10) = "f"
	Debug.Assert LBound(arr) = 0 And UBound(arr) = 10
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 11
	Debug.Assert idx = 10
	
	' appending value with a gap that is bigger than it's current size
	idx = 25
	arrayAppend arr, idx, "g"
	Debug.Assert arr(0) = "a" And arr(1) = "b" And arr(2) = "c" And arr(3) = "d" And arr(4) = "e"
	Debug.Assert arr(5) = "" And arr(9) = "" And arr(10) = "f"
	Debug.Assert arr(11) = "" And arr(25) = "" And arr(26) = "g" And arr(27) = "" And arr(36) = ""
	Debug.Assert LBound(arr) = 0 And UBound(arr) = 36
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 37
	Debug.Assert idx = 26
	
	' trimming the array
	ReDim Preserve arr(LBound(arr) To idx)
	Debug.Assert arr(0) = "a" And arr(1) = "b" And arr(2) = "c" And arr(3) = "d" And arr(4) = "e"
	Debug.Assert arr(5) = "" And arr(9) = "" And arr(10) = "f"
	Debug.Assert arr(11) = "" And arr(25) = "" And arr(26) = "g"
	Debug.Assert LBound(arr) = 0 And UBound(arr) = 26
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 27
	Debug.Assert idx = 26
	
	Erase arr
	
	
	' starting with idx = 1
	idx = 1
	arrayAppend arr, idx, "a"
	Debug.Assert arr(1) = "a" And LBound(arr) = 1 And UBound(arr) = 1
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 1
	Debug.Assert idx = 1
	arrayAppend arr, idx, "b"
	Debug.Assert arr(1) = "a" And arr(2) = "b"
	Debug.Assert LBound(arr) = 1 And UBound(arr) = 2
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 2
	Debug.Assert idx = 2
	arrayAppend arr, idx, "c"
	Debug.Assert arr(1) = "a" And arr(2) = "b" And arr(3) = "c"
	Debug.Assert LBound(arr) = 1 And UBound(arr) = 4
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 4
	Debug.Assert idx = 3
	arrayAppend arr, idx, "d"
	Debug.Assert arr(1) = "a" And arr(2) = "b" And arr(3) = "c" And arr(4) = "d"
	Debug.Assert LBound(arr) = 1 And UBound(arr) = 4
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 4
	Debug.Assert idx = 4
	arrayAppend arr, idx, "e"
	Debug.Assert arr(1) = "a" And arr(2) = "b" And arr(3) = "c" And arr(4) = "d" And arr(5) = "e"
	Debug.Assert LBound(arr) = 1 And UBound(arr) = 8
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 8
	Debug.Assert idx = 5
	
	' trimming the array
	ReDim Preserve arr(LBound(arr) To idx)
	Debug.Assert arr(1) = "a" And arr(2) = "b" And arr(3) = "c" And arr(4) = "d" And arr(5) = "e"
	Debug.Assert LBound(arr) = 1 And UBound(arr) = 5
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 5
	Debug.Assert idx = 5
	
	' appending value with a gap
	idx = 9
	arrayAppend arr, idx, "f"
	Debug.Assert arr(1) = "a" And arr(2) = "b" And arr(3) = "c" And arr(4) = "d" And arr(5) = "e"
	Debug.Assert arr(6) = "" And arr(9) = "" And arr(10) = "f"
	Debug.Assert LBound(arr) = 1 And UBound(arr) = 10
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 10
	Debug.Assert idx = 10
	
	' trimming the array
	ReDim Preserve arr(LBound(arr) To idx)
	Debug.Assert arr(1) = "a" And arr(2) = "b" And arr(3) = "c" And arr(4) = "d" And arr(5) = "e"
	Debug.Assert arr(6) = "" And arr(9) = "" And arr(10) = "f"
	Debug.Assert LBound(arr) = 1 And UBound(arr) = 10
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 10
	Debug.Assert idx = 10
	
	' appending value with a gap that is bigger than it's current size
	idx = 25
	arrayAppend arr, idx, "g"
	Debug.Assert arr(1) = "a" And arr(2) = "b" And arr(3) = "c" And arr(4) = "d" And arr(5) = "e"
	Debug.Assert arr(6) = "" And arr(9) = "" And arr(10) = "f"
	Debug.Assert arr(11) = "" And arr(25) = "" And arr(26) = "g" And arr(27) = "" And arr(35) = ""
	Debug.Assert LBound(arr) = 1 And UBound(arr) = 35
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 35
	Debug.Assert idx = 26
	
	' trimming the array
	ReDim Preserve arr(LBound(arr) To idx)
	Debug.Assert arr(1) = "a" And arr(2) = "b" And arr(3) = "c" And arr(4) = "d" And arr(5) = "e"
	Debug.Assert arr(6) = "" And arr(9) = "" And arr(10) = "f"
	Debug.Assert arr(11) = "" And arr(25) = "" And arr(26) = "g"
	Debug.Assert LBound(arr) = 1 And UBound(arr) = 26
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 26
	Debug.Assert idx = 26
	
	Erase arr
	
	
	' starting with idx = 10
	idx = 10
	arrayAppend arr, idx, "a"
	Debug.Assert arr(10) = "a" And LBound(arr) = 10 And UBound(arr) = 10
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 1
	Debug.Assert idx = 10
	arrayAppend arr, idx, "b"
	Debug.Assert arr(10) = "a" And arr(11) = "b"
	Debug.Assert LBound(arr) = 10 And UBound(arr) = 11
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 2
	Debug.Assert idx = 11
	arrayAppend arr, idx, "c"
	Debug.Assert arr(10) = "a" And arr(11) = "b" And arr(12) = "c"
	Debug.Assert LBound(arr) = 10 And UBound(arr) = 13
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 4
	Debug.Assert idx = 12
	arrayAppend arr, idx, "d"
	Debug.Assert arr(10) = "a" And arr(11) = "b" And arr(12) = "c" And arr(13) = "d"
	Debug.Assert LBound(arr) = 10 And UBound(arr) = 13
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 4
	Debug.Assert idx = 13
	arrayAppend arr, idx, "e"
	Debug.Assert arr(10) = "a" And arr(11) = "b" And arr(12) = "c" And arr(13) = "d" And arr(14) = "e"
	Debug.Assert LBound(arr) = 10 And UBound(arr) = 17
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 8
	Debug.Assert idx = 14
	
	' trimming the array
	ReDim Preserve arr(LBound(arr) To idx)
	Debug.Assert arr(10) = "a" And arr(11) = "b" And arr(12) = "c" And arr(13) = "d" And arr(14) = "e"
	Debug.Assert LBound(arr) = 10 And UBound(arr) = 14
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 5
	Debug.Assert idx = 14
	
	' appending value with a gap
	idx = 18
	arrayAppend arr, idx, "f"
	Debug.Assert arr(10) = "a" And arr(11) = "b" And arr(12) = "c" And arr(13) = "d" And arr(14) = "e"
	Debug.Assert arr(18) = "" And arr(19) = "f"
	Debug.Assert LBound(arr) = 10 And UBound(arr) = 19
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 10
	Debug.Assert idx = 19
	
	' trimming the array
	ReDim Preserve arr(LBound(arr) To idx)
	Debug.Assert arr(10) = "a" And arr(11) = "b" And arr(12) = "c" And arr(13) = "d" And arr(14) = "e"
	Debug.Assert arr(18) = "" And arr(19) = "f"
	Debug.Assert LBound(arr) = 10 And UBound(arr) = 19
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 10
	Debug.Assert idx = 19
	
	' appending value with a gap that is bigger than it's current size
	idx = 35
	arrayAppend arr, idx, "g"
	Debug.Assert arr(10) = "a" And arr(11) = "b" And arr(12) = "c" And arr(13) = "d" And arr(14) = "e"
	Debug.Assert arr(18) = "" And arr(19) = "f"
	Debug.Assert arr(35) = "" And arr(36) = "g" And arr(37) = ""
	Debug.Assert LBound(arr) = 10 And UBound(arr) = 45
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 36
	Debug.Assert idx = 36
	
	' trimming the array
	ReDim Preserve arr(LBound(arr) To idx)
	Debug.Assert arr(10) = "a" And arr(11) = "b" And arr(12) = "c" And arr(13) = "d" And arr(14) = "e"
	Debug.Assert arr(18) = "" And arr(19) = "f"
	Debug.Assert arr(35) = "" And arr(36) = "g"
	Debug.Assert LBound(arr) = 10 And UBound(arr) = 36
	Debug.Assert UBound(arr) - LBound(arr) + 1 = 27
	Debug.Assert idx = 36
	
	Erase arr
	
End Sub

' Returns TRUE if the array is allocated (either a static array or a dynamic array that has been
' sized with Redim) or FALSE if the array is not allocated (a dynamic that has not yet
' been sized with Redim, or a dynamic array that has been Erased). Static arrays are always
' allocated.
'
' The VBA IsArray function indicates whether a variable is an array, but it does not
' distinguish between allocated and unallocated arrays. It will return TRUE for both
' allocated and unallocated arrays. This function tests whether the array has actually
' been allocated.
'
' This function is just the reverse of IsArrayEmpty.
'
' @see http://www.cpearson.com/Excel/isArrayAllocated.aspx
' @see http://www.cpearson.com/excel/VBAArrays.htm

Public Function isArrayAllocated(arr As Variant) As Boolean

	Dim n As Long
	On Error Resume Next
	
	' if Arr is not an array, return FALSE and get out.
	If IsArray(arr) = False Then
		isArrayAllocated = False
		Exit Function
	End If
	
	' Attempt to get the UBound of the array. If the array has not been allocated,
	' an error will occur. Test Err.Number to see if an error occurred.
	n = UBound(arr, 1)
	If Err.Number = 0 Then
		' Under some circumstances, if an array is not allocated, Err.Number will be
		' 0. To acccomodate this case, we test whether LBound <= Ubound. If this
		' is True, the array is allocated. Otherwise, the array is not allocated.
		If LBound(arr) <= UBound(arr) Then
			' no error. array has been allocated.
			isArrayAllocated = True
		Else
			isArrayAllocated = False
		End If
	Else
		' error. unallocated array
		isArrayAllocated = False
	End If
	
End Function