Excel 记录计数为1时，由ADODB记录集填充的动态列表框不显示项

嗨，我的列表框有问题

我想查一下餐厅每张桌子上坐着多少人，还有多少人等着坐下。为此，我使用SheetLeunchRoom作为数据库，并使用ADODB记录集获取每个表的结果

我不明白为什么列表框只有一条记录没有被填充

Sub UserForm_Initialize()

    Dim ctrl As Control
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim i As Integer, L As Integer, T As Integer, W As Integer, H As Integer
    Dim strsql As String
    Dim ArrTables, arr, arrPax, lbx As ListBox

    Const adOpenStatic = 3
    Const adLockOptimistic = 3
    Const adCmdText = &H1
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    Set rs = New ADODB.Recordset
    Set LBs = New Collection

    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & ThisWorkbook.FullName & "; Extended Properties=""Excel 8.0;HDR=Yes;"";"

    strsql = "Select IdClients, Paxname, PaxSurname from [LunchRoom$] where Table is null"
    rs.Open strsql, cn, adOpenStatic, adLockReadOnly, adCmdUnspecified

    If rs.EOF Then lbPaxNoTable.Caption = "Noboby can be seat": GoTo PaxOnTable

    rs.MoveFirst
    arr = rs.GetRows

    With Me.LbxPaxNotSeating
        .Clear
        .ColumnCount = 3
        .ColumnWidths = "0;30;30"
        .List = Application.Transpose(arr)
        .ListIndex = 0
    End With

    lbPaxNoTable.Caption = rs.RecordCount & " people wait to sit down"

    PaxOnTable:
    Set rs = Nothing

    strsql = "Select distinct Table FROM [Tables$]"
    rs.Open strsql, cn, adOpenStatic, adLockReadOnly, adCmdUnspecified
    ReDim ArrTables(0 To rs.RecordCount)

    i = 0
    Do Until rs.EOF
        ArrTables(i) = rs![Table]
        rs.MoveNext
        i = i + 1
    Loop
    Set rs = Nothing

    L = 24
    T = 150
    W = 165
    H = 94

    For i = 0 To UBound(ArrTables) - 1
        If i = 3 Then T = 252: L = 24
        strsql = "Select IdClients, Paxname, PaxSurname from [LunchRoom$] where Table = '" & ArrTables(i) & "'"
        rs.Open strsql, cn, adOpenStatic, adLockReadOnly, adCmdUnspecified
        If rs.EOF Then arrPax = Null Else arrPax = rs.GetRows
        Call Add_Dynamic_lbx(ArrTables(i), "Forms.ListBox.1", arrPax, L, T, H, W)
        Me.Controls("lb" & ArrTables(i)).Caption = rs.RecordCount & " people are seated on " & ArrTables(i)
        L = L + 3 + W
        Set rs = Nothing
    Next i

    Dim lb As MSForms.ListBox
    Dim LMB As ListBoxDragAndDropManager
    Set LBs = New Collection

    For Each ctrl In Me.Controls
        If TypeName(ctrl) = "ListBox" Then
            Set LMB = New ListBoxDragAndDropManager
            Set LMB.ThisListBox = ctrl
            LBs.Add LMB
        End If
    Next

    fastexit:
    Set rs = Nothing
    Set cn = Nothing

End Sub

Sub Add_Dynamic_lbx(ByVal nome As String, ctr As String, val, L As Integer, T As Integer, H As Integer, W As Integer)

    Dim lbl As Control, code As String, NextLine As Long
    Set lbl = FrmPlan.Controls.Add(ctr)
    With lbl
        .name = nome
        .Clear
        .ColumnCount = 3
        If Not IsNull(val) Then
            .List = Application.Transpose(val):
            .ListIndex = -1
        End If
        .Width = W
        .ColumnWidths = "0;30;150"               '1th=0 to hide the IdRst
        .Height = H
        .Left = L
        .Top = T
        .ControlTipText = nome
    End With

End Sub

当您转置从GetRows返回的二维数组时，如果rows维度只有一个插槽，那么您将得到一个一维数组，而不是预期的翻转二维数组

如果查看“监视”窗口，可以看到这一点：我运行了一个只返回一行的查询，使用GetRows填充arr，然后使用Transpose填充arr2-

请注意，arr2是一个一维数组。将其与下面相同的代码和两个记录结果集进行比较：

不要使用Application.Transpose，请尝试使用如下VBA函数：

---

添加一些断点，然后查看代码的哪些部分没有执行。@所有代码都已执行，但没有出现错误。每个列表框下方的标签包含正确的rst编号，但如果只有一个rst，则列表框为空。您有rs。打开strsql、cn、adOpenStatic、adLockReadOnly、ADCMDMUNTE明，但在上面大约8行，您设置了rs=Nothing，因此会引发错误？我打开并关闭每个表的rs。我没有错。问题是：arrPax=rs.GetRows.List=Application.Transposeval如果rs.GetRows仅为1行，则Correspondent列表框不显示唯一记录！！谢谢，我更改了我的代码：如果rs.RecordCount>1，那么arrPax=Application.transpers.GetRows，否则arrPax=transpersearrayrs.GetRows，对于popolate，只需将列表框.list=arrPax。您可以通过始终使用VBA函数而忽略Application.Transpose，从而简化代码