由于 redim 数组导致下标超出范围错误

Question

The basic mission of this code is to use a list as the source of data for my a listbox control...with a catch. I only want the rows that have black cell in column 14 of the list.

To accomplish this, I attempted to assign an the cells to an array and assign the array using the list property.

I feel like I have read every refence document available and adhered to all the references, but I continually get this 'subscript out of range' error when 'redimming' the array in a preserved fashion after a for...next loop.

Before I use a temporary list to store my data construct, I really want to nail this dynamic array...but if it is too much work, then I'll have to settle for the easier option. Also, this is a learning process. Also, please forgive my sloppy indentations and everything else.

Option Explicit

'This code initializes the frmEntry form and sets the list box control
' to list the active escorts (escort records that have blank values
' in the 'End' field of the visitor log (VLog tabl on Visitor Log worksheet).

Private Sub UserForm_Initialize()

Dim wksVisitorLog As Worksheet
Dim wbkVMS As Workbook
Dim Last_Row As Long
Dim objVisitorEscortList As ListObject
Dim objListRow As ListRows
Dim objListCols As ListColumns
Dim listCounter As Single
Dim rowCounter As Single
Dim listArray()
Dim ri As Single
Dim ci As Single
Dim c As Single


Set wbkVMS = ThisWorkbook
Set wksVisitorLog = wbkVMS.Worksheets("Visitor Log")
Set objVisitorEscortList = wksVisitorLog.ListObjects("tblVisitorEscortLog")
Set objListRow = objVisitorEscortList.ListRows
Set objListCols = objVisitorEscortList.ListColumns
rowCounter = 0
ri = 0
ci = 0
c = 0

'Prepares the list box.
With frmEntry
  
  .listboxActiveEscorts.Clear
  .listboxActiveEscorts.ColumnCount = "15"
  .listboxActiveEscorts.ColumnHeads = True
  .listboxActiveEscorts.ColumnWidths = "80,100,100,0,0,100,100,0,0,50,0,0,80,80,80"
    
End With

ReDim listArray(ri, 14)

'This section adds Escort/Visitor records to list box
For listCounter = 1 To objListRow.Count 'Increments based on the total rows on "Visitor Log"
  
    'Selects the row if the "End" field (14th column) is blank
    If objVisitorEscortList.Range.Cells(listCounter + 1, 14) = "" Then
    
      'Increments the row for the listbox array, and will only increment when the if condition is true

        For ci = 0 To 14 'Starts inner loop index for the listbox control column
      
             c = c + 1 'Increments the list range column of the "Visitor Log"
        
        'This portion of the code assigns the two dimensional array index
        listArray(ri, ci) = objVisitorEscortList.Range.Cells(listCounter + 1, c).Value
 
        Next ci
    
    End If
ReDim Preserve listArray(UBound(listArray, 1) + 1)

Next listCounter

'Assigns the entire array to list
listboxActiveEscorts.List = listArray

MsgBox "There are " & frmEntry.listboxActiveEscorts.ListCount & " total active escorts at this time", vbOKOnly

listCounter = 0

End Sub

Answer 1

welcome, the issue is that you declare a 2 dimensional array: ReDim listArray(ri, 14)

this would be similar to: ReDim listArray(0 to ri, 0 to 14)

meaning that there are 0 to ri rows and 0 to 14 columns in each row.

then you attempt to redim preserve it by only listing the row section: ReDim Preserve listArray(UBound(listArray, 1) + 1)

in order to redim a 2 dimensional array you must transpose the array before adding any extra rows. If you want to add another column, you do not have to transpose the array.

you can use the function:

Function varTransposeArray(varInput As Variant) As Variant
' brief, will transpose, flip the row and columns for a 2 dimensional array
' argument, varInput, the array that should be transpose, it can be oany type array, string, integer, varaint, etc, but function will return a variant.
    Dim lRow As Long, lColumn As Long
    Dim vTemporaryArray As Variant

    ' redim vTemporaryArray to the dimensions of varInput
    ' must specify both lbound and uBound for both dimensions otherwise the output might not be correct, for example, it might have a lBound of 0 instead of 1
    ReDim vTemporaryArray(LBound(varInput, 2) To UBound(varInput, 2), LBound(varInput, 1) To UBound(varInput, 1))
    
    ' loop through all values of varInput
    For lRow = LBound(varInput, 2) To UBound(varInput, 2)
        For lColumn = LBound(varInput, 1) To UBound(varInput, 1)
            
            ' transpose, or flip, the row and column of varInput into vTemporaryArray
            If Not VarType(varInput(lColumn, lRow)) = vbObject Then
                vTemporaryArray(lRow, lColumn) = varInput(lColumn, lRow)
            Else
                Set vTemporaryArray(lRow, lColumn) = varInput(lColumn, lRow)
            End If
            
        Next lColumn
    Next lRow

    varTransposeArray = vTemporaryArray

end function

then you can use:

listArray = varTransposeArray(listArray)
                    ReDim Preserve listArray(LBound(listArray, 1) To UBound(listArray, 1), LBound(listArray, 2) To UBound(listArray, 2) + 1)
                    listArray = varTransposeArray(listArray)

                

If this answers your question, click thumbs up, thanks.

Answer 2

I was able to get my ListBox to populate using a filtered range from an Excel WorkSheet by using a dynamic array...without transposing rows and columns. The data seems intact. I am able to select an item(row) in the list, which populates in assigned controls. Here is the code I used:

Private Sub UserForm_Initialize()

'Workbook and Worksheets
Dim wbkVMS As Workbook: Set wbkVMS = ThisWorkbook
Dim wksVisitorLog As Worksheet, wksAcctInfo As Worksheet

'List Objects and List Object Properties
Dim objVisitorEscortList As ListObject, loVisBadge As ListObject
Dim objListRow As ListRows
Dim objListCols As ListColumns ':Set objListCols = objVisitorEscortList.ListColumns
Dim objVIDType As ListObject

'Variables and Arrays
Dim vbArray() As Variant, listArray() As Variant, arrVIDType() As String
Dim vbArrayCount As Single, rowCount As Integer, listCounter As Integer, iVID As Integer
Dim ivb As Integer, ri As Integer, ci As Integer, c As Integer, i As Single, arrayColumnIndex As Integer
Dim cVID As Integer

'Variable assignments
Set wksVisitorLog = wbkVMS.Worksheets("Visitor Log")
Set objVisitorEscortList = wksVisitorLog.ListObjects("tblVisitorEscortLog8")
Set wksAcctInfo = wbkVMS.Worksheets("Account Information")
Set loVisBadge = wksAcctInfo.ListObjects("tblVisitorBadge")
Set objListRow = objVisitorEscortList.ListRows
vbArrayCount = loVisBadge.ListRows.Count
Set objVIDType = Worksheets("Supplemental Lists").ListObjects("tblVIDType")
iVID = objVIDType.ListRows.Count

'Prepares the Active Escorts list box.
ivb = 0
i = 0
With frmEntry
      
    .listboxActiveEscorts.Clear
    .listboxActiveEscorts.ColumnHeads = False
    .listboxActiveEscorts.ColumnCount = "15"
    .listboxActiveEscorts.ColumnWidths = "0,100,100,0,0,100,100,0,0,0,0,0,100,100,80"
    
    'Adds identification types of Visitor Identification Control
    ReDim arrVIDType(0 To iVID - 1)
    For i = 0 To iVID - 1
        cVID = cVID + 1
        arrVIDType(cVID - 1) = objVIDType.Range.Cells(i + 2, 1)
    Next i
    .cbxVIdentification.List = arrVIDType
    i = 0
        
    'Add badge #s to combobox
    ReDim vbArray(0 To vbArrayCount - 1)
    For i = 0 To vbArrayCount - 1
        ivb = ivb + 1
        vbArray(ivb - 1) = loVisBadge.Range.Cells(i + 2, 1).Value
    Next i
    .cbxVisitorBadgeNumber.List = vbArray
    
End With

'This section adds Escort/Visitor records to list box
i = 0
ri = 0
ci = 0
c = 0
rowCount = wksVisitorLog.Range("N1").Value
rowCount = rowCount - 1
ReDim listArray(rowCount, 14)
For listCounter = 1 To objListRow.Count 'Increments based on the total rows on "Visitor Log"
    'Selects the row if the "End" field (14th column) is blank
    If objVisitorEscortList.Range.Cells(listCounter + 1, 14) = "" Then
        ri = ri + 1
        For ci = 0 To 14 'Starts inner loop index for the listbox control column
            c = c + 1 'Increments the list range column of the "Visitor Log"
            listArray(ri - 1, ci) = objVisitorEscortList.Range.Cells(listCounter + 1, c).Value
        Next ci
    End If
    c = 0
Next listCounter
'Assigns the entire array to list
listboxActiveEscorts.List = listArray

MsgBox "There are " & frmEntry.listboxActiveEscorts.ListCount & " total active escorts at this time", vbOKOnly

End Sub

The outer loop cycles through an Excel range, and while cycling through the loop checks for a condition. If that condition is true, the code executes an inner loop which cycles through each column of the Excel row that met the condition.

Then, basically, I have an iterator and a counter. The counter increments inside the loop independently of the increments of the array, keeping the indexes succinct. After assigning values to the array index using the loop, the dynamic array is assigned to the ListBox array. The ListBox will grow or shrink depending the on the filtered items in the range.

I have to figure out how to clear the array from the ComboBoxes...another problem I have to solve.