如何将Access查询结果导入Excel多列ListBox并正确显示？

问题说明 #

我尝试在Access中执行指定查询，将查询结果导入Excel中创建的ListBox（该ListBox包含少于10列）。现有类似代码可实现单列查询结果的填充，但当前多列查询的代码无法正确显示多列数据，请问如何调整代码以实现多列数据的正常显示？

原代码 #

'Set the name of the query you want to run and retrieve the data
Query = "SELECT [05_REQUESTED_ITEM].Manufacturer, [05_REQUESTED_ITEM].Quantity, [05_REQUESTED_ITEM].Description, [05_REQUESTED_ITEM].Application, [06_ITEM_DETAILS].Item, [06_ITEM_DETAILS].MAT_RFQ, [06_ITEM_DETAILS].Dimensions, [06_ITEM_DETAILS].Component, [06_ITEM_DETAILS].Part FROM (01_INPUT_DATA LEFT JOIN 05_REQUESTED_ITEM ON [01_INPUT_DATA].[SPET_ID] = [05_REQUESTED_ITEM].[SPET_ID]) LEFT JOIN 06_ITEM_DETAILS ON [01_INPUT_DATA].[SPET_ID] = [06_ITEM_DETAILS].[SPET_ID] WHERE ((([01_INPUT_DATA].SPET_ID)='" & ID & "'));"

On Error Resume Next

'Create the ADODB recordset object
Set rs = New ADODB.Recordset

'Check if the object was created.
If Err.Number <> 0 Then
    
    'Error! Release the objects and exit
    Set rs = Nothing
    Set cnt = Nothing
    
    'Display an error message to the user
    MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
    
    Exit Function

End If

On Error Resume Next 'GOTO 0
         
'Set the cursor location and type, the lock type and the options
rs.CursorLocation = 2 ' = adUseServer '3 = adUseClient on early  binding
rs.CursorType = 2 ' = adOpenDynamic '1 = adOpenKeyset on early  binding
    
'Open the recordset
rs.Open Source:=Query, _
    ActiveConnection:=cnt
    
'Check if the recordset is empty
If rs.EOF And rs.BOF Then
    MsgBox "hello", vbOKOnly
    'Release the object
    Set rs = Nothing

Else
    
    'Explore the recordset
    rs.MoveFirst
    'ReadData = rs.GetRows
    
    With SEARCH_TOOL.SA_Result_Item_ListBox
        .Clear
        .ColumnCount = rs.Fields.Count
        For i = 0 To .ColumnCount
            ReadData = rs.GetRows(i)
            .List(i) = Application.WorksheetFunction.Transpose(ReadData)
        Next i
    End With
    
End If

问题分析与修改方案 #

原代码核心问题在于错误使用GetRows方法和循环逻辑，同时游标位置设置不当导致数据获取异常：

1. rs.CursorLocation = 2（adUseServer）会限制GetRows功能，改用客户端游标（adUseClient）才能稳定获取完整数据集。
2. 逐列循环调用GetRows(i)是错误逻辑，GetRows默认一次性获取所有记录，返回列优先的二维数组，转置后即可匹配ListBox的行优先结构。
3. 循环范围For i = 0 To .ColumnCount超出列索引范围（列索引从0开始，应到.ColumnCount - 1），且实际无需逐列处理。

修改后的代码 #

'Set the name of the query you want to run and retrieve the data
Query = "SELECT [05_REQUESTED_ITEM].Manufacturer, [05_REQUESTED_ITEM].Quantity, [05_REQUESTED_ITEM].Description, [05_REQUESTED_ITEM].Application, [06_ITEM_DETAILS].Item, [06_ITEM_DETAILS].MAT_RFQ, [06_ITEM_DETAILS].Dimensions, [06_ITEM_DETAILS].Component, [06_ITEM_DETAILS].Part FROM (01_INPUT_DATA LEFT JOIN 05_REQUESTED_ITEM ON [01_INPUT_DATA].[SPET_ID] = [05_REQUESTED_ITEM].[SPET_ID]) LEFT JOIN 06_ITEM_DETAILS ON [01_INPUT_DATA].[SPET_ID] = [06_ITEM_DETAILS].[SPET_ID] WHERE ((([01_INPUT_DATA].SPET_ID)='" & ID & "'));"

On Error GoTo ErrorHandler

'Create the ADODB recordset object
Set rs = New ADODB.Recordset

'Set cursor to client-side for stable GetRows functionality
rs.CursorLocation = 3 'adUseClient
rs.CursorType = 1 'adOpenKeyset 静态游标更适合只读数据场景

'Open the recordset
rs.Open Source:=Query, ActiveConnection:=cnt

'Check if the recordset is empty
If rs.EOF And rs.BOF Then
    MsgBox "无匹配数据", vbOKOnly
    GoTo Cleanup
End If

With SEARCH_TOOL.SA_Result_Item_ListBox
    .Clear
    .ColumnCount = rs.Fields.Count
    '一次性获取所有数据，转置后直接赋值给List属性
    .List = Application.WorksheetFunction.Transpose(rs.GetRows)
    '可选：设置列宽，数值单位为磅，可根据实际内容调整
    .ColumnWidths = "80,60,120,100,80,80,100,80,80"
End With

Cleanup:
'释放对象
Set rs = Nothing
Set cnt = Nothing
Exit Function

ErrorHandler:
MsgBox "错误：" & Err.Description, vbCritical, "执行错误"
GoTo Cleanup

关键调整说明 #

• 游标设置：将rs.CursorLocation改为3（adUseClient），确保GetRows能正确读取完整数据集。
• 数据填充：直接用rs.GetRows获取所有数据，转置后赋值给ListBox的.List属性，这是填充多列ListBox的高效方式，无需逐列循环。
• 错误处理：替换On Error Resume Next为On Error GoTo结构，精准捕获并展示错误，避免隐藏问题。
• 列宽设置：添加.ColumnWidths属性，确保每列内容正常显示，可根据实际列内容长度调整数值。

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