ATTN: Alan Beban. Problem with ResizeArray

[Excel dweeb]

Apologies for the size of this post, and beware of line wrap in the
routines provided below.

In trying to diagnose why ResizeArray wasn't setting the second
dimension (of a 2D array) properly, I added a msgbox statement to
Alan's sub, but I never see any output from it. I include both the
test program and the modified ResizeArray below. numdimensionT seems
to be set improperly to "1" rather than "2," but what's really odd is
that I can't get the msgbox to give me the dimensions of arr2 within
ResizeArray.

Any guidance greatly appreciated.

Option Explicit
Option Base 1
Sub test_resize()
Dim john() As Variant
ReDim john(1 To 1, 1 To 1) As Variant

Call ResizeArray(john, UBound(john, 1) + 9, 11)

MsgBox "size: " & UBound(john, 1) & " x " & UBound(john, 2)

End Sub

Sub ResizeArray(ByRef myArray As Variant, _
ByVal new1 As Long, _
Optional ByVal new2, _
Optional ByVal new3)

'ReDim Preserve can be used to change the size of
'only the last dimension of an array while
'preserving its values; this Sub procedure, while
'preserving the values of the array that is passed
'to it, will change the size of any or all of the
'dimensions of a one-, two- or three-dimensional array.
'Its arguments are the array and its new dimensions.
'
' N.B.: This routine created by, and courtesy of, Alan Beban
'

Dim arr1, arr2, i As Long, j As Long, k As Long, Msg As String
Dim NumDimensions As Integer, p As Integer, t As Integer, zz As
Integer, z As Integer
Dim NumDimensionsT As Integer

'Insure that an array is passed to this Sub procedure
If Not IsArray(myArray) Or IsObject(myArray) Then
MsgBox "The first argument passed to this " & _
"procedure must be an array"
Exit Sub
End If

'Establish the number of dimensions of the input array
On Error Resume Next
p = 1
Do
z = UBound(myArray, p)
p = p + 1
Loop While Err = 0
Err = 0
NumDimensions = p - 2

Select Case NumDimensions
Case 1
ReDim Preserve myArray(LBound(myArray, 1) To new1)
arr1 = myArray

Case 2
If IsMissing(new2) Then
Msg = "The second argument is not optional for this case."
MsgBox Msg, 16
Exit Sub
End If
If (UBound(myArray) - LBound(myArray) + 1) * (UBound(myArray,
2) - LBound(myArray, 2) + 1) <= 5461 Then
t = 1
Do
zz = UBound(Application.Transpose(myArray), t)
t = t + 1

Loop While Err = 0
Err = 0
NumDimensionsT = t - 2
End If
If new1 = UBound(myArray, 1) Then
ReDim Preserve myArray(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2)
Exit Sub
Else
Select Case TypeName(myArray)
Case "Byte()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As Byte
Case "Boolean()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As Boolean
Case "Integer()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As Integer
Case "Long()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As Long
Case "Currency()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As Currency
Case "Single()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As Single
Case "Double()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As Double
Case "Date()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As Date
Case "String()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As String
Case "Object()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As Object
For i = LBound(myArray, 1) To _
Application.Min(UBound(myArray, 1), new1)
For j = LBound(myArray, 2) To _
Application.Min(UBound(myArray, 2), new2)
Set arr1(i, j) = myArray(i, j)
Next
Next
Case "Variant()"

ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2) As Variant
Case Else
MsgBox "This procedure accepts arrays" & Chr(13) &
_
"of only the following types:" & Chr(13) &
Chr(13) & _
" Byte()" & Chr(13) & _
" Boolean()" & Chr(13) & _
" Integer()" & Chr(13) & _
" Long()" & Chr(13) & _
" Single()" & Chr(13) & _
" Double()" & Chr(13) & _
" Date()" & Chr(13) & _
" Currency()" & Chr(13) & _
" String()" & Chr(13) & _
" Object()" & Chr(13) & _
" Variant()": Exit Sub
End Select
If TypeName(myArray) <> "Object()" Then
If (UBound(myArray) - LBound(myArray) + 1) *
(UBound(myArray, 2) - LBound(myArray, 2) + 1) > 5461 _
Or new2 < UBound(myArray, 2) Or TypeName(myArray)
<> "Variant()" Or UBound(myArray) <> 1 Then
For i = LBound(myArray, 1) To _
Application.Min(UBound(myArray, 1), new1)
For j = LBound(myArray, 2) To _
Application.Min(UBound(myArray, 2), new2)
arr1(i, j) = myArray(i, j)
Next
Next
Else
arr2 = Application.Transpose(myArray)
MsgBox "in RA, right before arr2 size"
MsgBox "In RA, size of arr2: " & UBound(arr2, 1) & " x " &
UBound(arr2, 2)
MsgBox "In RA, NumDimensionsT: " & NumDimensionsT
If NumDimensionsT = 1 Then
ReDim Preserve arr2(LBound(arr2) To new1)
Else
ReDim Preserve arr2(LBound(arr2) To new2,
LBound(arr2, 2) To new1)
End If
arr1 = Application.Transpose(arr2)

End If
End If
End If
Case 3
If IsMissing(new2) Or IsMissing(new3) Then
Msg = "The second and third arguments " & _
"are not optional for this case."
MsgBox Msg, 16
Exit Sub
End If
If new1 = UBound(myArray, 1) And new2 = _
UBound(myArray, 2) Then
ReDim Preserve myArray(LBound(myArray, 1) _
To new1, LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3)
Exit Sub
Else
Select Case TypeName(myArray)
Case "Byte()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As Byte
Case "Boolean()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As Boolean
Case "Integer()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As Integer
Case "Long()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As Long
Case "Currency()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As Currency
Case "Single()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As Single
Case "Double()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As Double
Case "Date()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As Date
Case "String()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As String
Case "Object()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As Object
Case "Variant()"
ReDim arr1(LBound(myArray, 1) To new1, _
LBound(myArray, 2) To new2, _
LBound(myArray, 3) To new3) As Variant
Case Else
MsgBox "This procedure accepts arrays" & Chr(13) &
_
"of only the following types:" & Chr(13) &
Chr(13) & _
" Byte()" & Chr(13) & _
" Boolean()" & Chr(13) & _
" Integer()" & Chr(13) & _
" Long()" & Chr(13) & _
" Single()" & Chr(13) & _
" Double()" & Chr(13) & _
" Date()" & Chr(13) & _
" Currency()" & Chr(13) & _
" String()" & Chr(13) & _
" Object()" & Chr(13) & _
" Variant()": Exit Sub
End Select
If TypeName(myArray) <> "Object()" Then
For i = LBound(myArray, 1) To _
Application.Min(UBound(myArray, 1), new1)
For j = LBound(myArray, 2) To _
Application.Min(UBound(myArray, 2), new2)
For k = LBound(myArray, 3) To _
Application.Min(UBound(myArray, 3), new3)
arr1(i, j, k) = myArray(i, j, k)
Next
Next
Next
End If
End If
Case Else
Msg = "This procedure accepts only 1-D, 2-D, and 3-D arrays."
MsgBox Msg, 16
End Select
myArray = arr1
End Sub

 

[Alan Beban]

In trying to diagnose why ResizeArray wasn't setting the second
dimension (of a 2D array) properly, I added a msgbox statement to
Alan's sub, but I never see any output from it. I include both the
test program and the modified ResizeArray below. numdimensionT seems
to be set improperly to "1" rather than "2," but what's really odd is
that I can't get the msgbox to give me the dimensions of arr2 within
ResizeArray. [big snip]

Any guidance greatly appreciated.

I will post or email (if you've provided your email address) the fix.
The error results from my misguided attempt to utilize the built-in
functions rather my own when the array was small enough for the built-in
functions to work. As a result, in the line

zz = UBound(Application.Transpose(myArray), t)

Application.Transpose(myArray) is a 1-D array, even though myArray is a
2-D array. That's the way the TRANSPOSE function works. You can verify
that with

Dim arr(1 To 1, 1 To 1)
MsgBox ArrayDimensions(Application.Transpose(arr))

As a result, NumDimensionsT is (erroneously) 1.

So when your code tries try to execute

MsgBox "In RA, size of arr2: " & _
UBound(arr2, 1) & " x " & UBound(arr2,2)

UBound(arr2,2) throws a Subscript out of range error, so the line
doesn't execute; because the On Error Resume Next statement is still in
effect, it goes on to execute the rest of the code.

If your email return address is not correct in your post, email it to me
and I will email you the fix before I load it onto the website.

I very much appreciate your bringing it to my attention.

Alan Beban