Sub ReDimPreserve2D_AnyDimension()
Dim MyArray() As Variant
ReDim MyArray(1, 3)
'put your code to populate your array here
For i = LBound(MyArray, 1) To UBound(MyArray, 1) For j = LBound(MyArray, 2) To UBound(MyArray, 2) MyArray(i, j) = i & "," & j Next j
Next i
MyArray = ReDimPreserve(MyArray, 2, 4)
End Sub
Private Function ReDimPreserve(MyArray As Variant, nNewFirstUBound As Long, nNewLastUBound As Long) As Variant Dim i, j As Long Dim nOldFirstUBound, nOldLastUBound, nOldFirstLBound, nOldLastLBound As Long Dim TempArray() As Variant 'Change this to "String" or any other data type if want it to work for arrays other than Variants. MsgBox UCase(TypeName(MyArray))
'---------------------------------------------------------------
'COMMENT THIS BLOCK OUT IF YOU CHANGE THE DATA TYPE OF TempArray If InStr(1, UCase(TypeName(MyArray)), "VARIANT") = 0 Then MsgBox "This function only works if your array is a Variant Data Type." & vbNewLine & _ "You have two choice:" & vbNewLine & _ " 1) Change your array to a Variant and try again." & vbNewLine & _ " 2) Change the DataType of TempArray to match your array and comment the top block out of the function ReDimPreserve" _ , vbCritical, "Invalid Array Data Type" End End If
'--------------------------------------------------------------- ReDimPreserve = False 'check if its in array first If Not IsArray(MyArray) Then MsgBox "You didn't pass the function an array.", vbCritical, "No Array Detected": End 'get old lBound/uBound nOldFirstUBound = UBound(MyArray, 1): nOldLastUBound = UBound(MyArray, 2) nOldFirstLBound = LBound(MyArray, 1): nOldLastLBound = LBound(MyArray, 2) 'create new array ReDim TempArray(nOldFirstLBound To nNewFirstUBound, nOldLastLBound To nNewLastUBound) 'loop through first For i = LBound(MyArray, 1) To nNewFirstUBound For j = LBound(MyArray, 2) To nNewLastUBound 'if its in range, then append to new array the same way If nOldFirstUBound >= i And nOldLastUBound >= j Then TempArray(i, j) = MyArray(i, j) End If Next Next 'return the array redimmed If IsArray(TempArray) Then ReDimPreserve = TempArray
End Function