Code:
Public Sub ReDimPreserve(arrPreserve, ByVal end_row2&, ByVal end_col2&, Optional ByVal start_row2, Optional ByVal start_col2)
'funtion: to break the limitation that ReDim Preserve cannot handle two-dimension array
'Param1: arrPreserve, original array to be ReDim Preserve
'Param2: end_row2, superscript of 1st dimension
'Param3: end_col2, superscript of 2nd dimension
'Param4: start_row2, subscript of 1st dimension, optional, original array 1st dimension subscript by default
'Param5: start_col2，subscript of 2nd dimension, optional, original array 2nd dimension subscript by default
'Attension: please make sure end_row2 >= start_row2, and end_col2 >= start_col2
Dim arrTemp As Variant
Dim i As Long, j As Long
Dim start_row1 As Long, end_row1 As Long 'original 1st dimension info
Dim start_col1 As Long, end_col1 As Long 'original 2nd dimension info
If Not IsArray(arrPreserve) Then Exit Sub
start_row1 = LBound(arrPreserve, 1)
end_row1 = UBound(arrPreserve, 1)
start_col1 = LBound(arrPreserve, 2)
end_col1 = UBound(arrPreserve, 2)
If VarType(start_row2) = 10 Then start_row2 = start_row1 'if not given, set to default
If VarType(start_col2) = 10 Then start_col2 = start_col1 'if not given, set to default
ReDim arrTemp(start_row2 To end_row2, start_col2 To end_col2) 'dynamic redim new array
If start_row2 > end_row1 Or _
end_row2 < start_row1 Or _
start_col2 > end_col1 Or _
end_col2 < start_col1 Then 'check if new array subscript or superscript out of original range
Err.Raise 0, "ReDimPreserve", "New array superscript or subscript out of range"
Exit Sub
Else 'contain part of origianl array data at least
If start_row2 > start_row1 Then start_row1 = start_row2
If start_col2 > start_col1 Then start_col1 = start_col2
If end_row2 < end_row1 Then end_row1 = end_row2
If end_col2 < end_col1 Then end_col1 = end_col2
For i = start_row1 To end_row1 'copy data by fixed range
For j = start_col1 To end_col1
arrTemp(i, j) = arrPreserve(i, j) 'copy data
Next
Next
arrPreserve = arrTemp 'return ByRef
End If
End SubCode:
Sub Test()
Dim arr
ReDim arr(1 To 4, 1 To 4)
Dim i&, j&
For i = 1 To 4
For j = 1 To 4
arr(i, j) = i & "-" & j
Next j
Next i
ReDimPreserve arr, 3, 3
ReDimPreserve arr, 3, 3, 0, 0
ReDimPreserve arr, 3, 3, 2, 2
End Sub