基于ComboBox选择填充UserForm ListBox时列数据异常问题排查

我有一个Excel VBA UserForm，希望仅展示ComboBox选中员工对应的ListBox结果。选中第一个员工姓名时结果正常，但选择其他ComboBox选项时，所有数据都被挤入ListBox的第一列。以下是用于填充ListBox的VBA代码：

Private Sub cbxEAName_Change()

Set shData = ThisWorkbook.Sheets("Data")

Dim rng As Range
Set rng = shData.Range("C2:G" & shData.Range("A" & shData.Rows.Count).End(xlUp).Row)

Dim filteredData() As Variant
Dim i As Long
Dim j As Long
Dim numRows As Long

numRows = 0
For i = 1 To rng.Rows.Count
    If rng.Cells(i, 1).Value = EmployeeAnalysis.cbxEAName.Value Then
        numRows = numRows + 1
        ReDim Preserve filteredData(1 To rng.Columns.Count, 1 To numRows)
        For j = 1 To rng.Columns.Count
            filteredData(j, numRows) = rng.Cells(i, j).Value
        Next j
    End If
Next i

With EmployeeAnalysis.lbxEmployeeResults
    .Clear
    .ColumnCount = rng.Columns.Count
    If numRows > 0 Then
        .List = Application.Transpose(filteredData)
    End If
    .ColumnWidths = "90;100;100;100;50"
    .TopIndex = 0
End With
End Sub

问题出在Application.Transpose的局限性上：当转置的数组只有1行数据时，Transpose返回一维数组，ListBox能正确识别为多列；但数据超过1行时，Transpose后的数组维度易出现异常，导致ListBox无法正确解析列结构。同时原代码每次匹配数据都用ReDim Preserve调整数组，效率低且易出错。以下是两种解决方案：

方案一：利用Range筛选（简洁高效） #

直接借助Excel筛选功能获取符合条件的数据，无需手动循环数组：

Private Sub cbxEAName_Change()
    Dim shData As Worksheet
    Set shData = ThisWorkbook.Sheets("Data")
    
    Dim lastRow As Long
    lastRow = shData.Range("A" & shData.Rows.Count).End(xlUp).Row
    Dim sourceRng As Range
    Set sourceRng = shData.Range("C2:G" & lastRow)
    
    ' 清除原有筛选
    If shData.AutoFilterMode Then shData.AutoFilterMode = False
    
    With EmployeeAnalysis.lbxEmployeeResults
        .Clear
        .ColumnCount = sourceRng.Columns.Count
        .ColumnWidths = "90;100;100;100;50"
        
        ' 筛选匹配员工的数据
        sourceRng.AutoFilter Field:=1, Criteria1:=EmployeeAnalysis.cbxEAName.Value
        On Error Resume Next ' 处理无匹配数据的情况
        Dim filteredRng As Range
        Set filteredRng = sourceRng.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not filteredRng Is Nothing Then
            .List = filteredRng.Value
        End If
        
        .TopIndex = 0
    End With
    
    ' 关闭筛选
    shData.AutoFilterMode = False
End Sub

方案二：修正数组维度处理 #

若坚持使用数组循环，需确保最终赋值给List的是二维数组，避免Transpose的问题：

Private Sub cbxEAName_Change()
    Dim shData As Worksheet
    Set shData = ThisWorkbook.Sheets("Data")
    
    Dim rng As Range
    Set rng = shData.Range("C2:G" & shData.Range("A" & shData.Rows.Count).End(xlUp).Row)
    
    Dim filteredData() As Variant
    Dim i As Long, j As Long, numRows As Long
    
    ' 先统计符合条件的行数
    numRows = 0
    For i = 1 To rng.Rows.Count
        If rng.Cells(i, 1).Value = EmployeeAnalysis.cbxEAName.Value Then
            numRows = numRows + 1
        End If
    Next i
    
    With EmployeeAnalysis.lbxEmployeeResults
        .Clear
        .ColumnCount = rng.Columns.Count
        .ColumnWidths = "90;100;100;100;50"
        
        If numRows > 0 Then
            ReDim filteredData(1 To numRows, 1 To rng.Columns.Count)
            Dim rowIdx As Long
            rowIdx = 1
            ' 填充数组
            For i = 1 To rng.Rows.Count
                If rng.Cells(i, 1).Value = EmployeeAnalysis.cbxEAName.Value Then
                    For j = 1 To rng.Columns.Count
                        filteredData(rowIdx, j) = rng.Cells(i, j).Value
                    Next j
                    rowIdx = rowIdx + 1
                End If
            Next i
            .List = filteredData ' 直接赋值二维数组，无需转置
        End If
        
        .TopIndex = 0
    End With
End Sub

内容的提问来源于stack exchange，提问作者Jared127