VBA - 从多个 ListObjects 填充 ListBox

在这样布置的电子表格中：

• 通过带有“格式为表格”的“主页”选项卡进行格式化；这将创建自动命名为“Table1”、“Table2”、“Table3”、“Table4”、“Table5”的 ListObjects
• 例如名为“列表框”的工作表

• 在此示例中添加了 ActiveX 命令按钮以显示名为 frmListbox 的用户表单：
  

  Sub Button2_Click()
      frmListbox.Show
  End Sub
  

    Private Sub cmdPopulate_Click()
        Dim ws As Worksheet
        Dim table As ListObject
        Dim rng As Range
        Dim i As Long, j As Long, criteriaRow As Long, lastCol As Long
        Dim myarray() As String

        With Me.lbUsed

            'Set relevant sheetname (or create loop for worksheets)
            Set ws = Sheets("listbox")

            criteriaRow = -1
            For Each table In ws.ListObjects
                'Set relevant range/table
                'Remember: top row are headings
                Set rng = ws.Range(table)

                'Remember: last colum not displayed in listbox (-1) for this example
                lastCol = rng.Columns.Count - 1

                .Clear
                .ColumnHeads = False
                .ColumnCount = lastCol

                'Remember: leave out row 0; column headings
                For i = 1 To rng.Rows.Count
                    If (rng.Cells(i, 3) = "Top") Then
                        criteriaRow = criteriaRow + 1
                        'Columns go in first demension so that rows can resize as needed
                        ReDim Preserve myarray(lastCol, criteriaRow)
                        For j = 0 To lastCol
                            myarray(j, criteriaRow) = rng.Cells(i, j + 1)
                        Next    'Column in table
                    End If
                Next    'Row in table
            Next    'Table (ListObject)

            'Place array in natural order to display in listbox
            .List = TransposeArray(myarray)

            'Set the widths of the column, separated with a semicolon
            .ColumnWidths = "100;75"
            .TopIndex = 0
        End With
    End Sub

    Public Function TransposeArray(myarray As Variant) As Variant
        Dim X As Long
        Dim Y As Long
        Dim Xupper As Long
        Dim Yupper As Long
        Dim tempArray As Variant

        Xupper = UBound(myarray, 2)
        Yupper = UBound(myarray, 1)
        ReDim tempArray(Xupper, Yupper)
        For X = 0 To Xupper
            For Y = 0 To Yupper
                tempArray(X, Y) = myarray(Y, X)
            Next Y
        Next X
        TransposeArray = tempArray
    End Function

对于第二个问题：

下面的代码示例显示当单击名为 lstDisorder 的列表中的项目时，如何使用电子表格上命名范围中的值填充名为 lstTreatment 的下一个列表框。

Private Sub lstDisorder_Click()
Dim x As Integer

x = lstDisorder.ListIndex
Select Case x
    Case Is = 0
        lstTreatment.RowSource = "Depression"
    Case Is = 1
        lstTreatment.RowSource = "Anxiety"
    Case Is = 2
        lstTreatment.RowSource = "OCD"
    Case Is = 3
        lstTreatment.RowSource = "Stubstance"
    End Select
End Sub

这是另一种方法：

Private Sub lstTeam_Click()

    Dim colUniqueItems      As New Collection
    Dim vItem               As Variant
    Dim rFound              As Range
    Dim FirstAddress        As String

    'First listBox
    Me.lstItems.Clear

    'populate first listBox from range on worksheet
    With Worksheets("Team").Range("A2:A" & (Cells(1000, 1).End(xlUp).row))
        'Find what was clicked in first listBox
        Set rFound = .Find(what:=lstTeam.Value, LookIn:=xlValues, lookat:=xlWhole)
        'If something is selected, populate second listBox
        If Not rFound Is Nothing Then
            'Get the address of selected item in first listBox
            FirstAddress = rFound.Address
            On Error Resume Next
            Do
                'Add the value of the cell to the right of the cell selected in first listBox to the collection
                colUniqueItems.Add rFound.Offset(, 1).Value, CStr(rFound.Offset(, 1).Value)
                'Find the next match in the range of the first listBox
                Set rFound = .FindNext(rFound)
            'Keep looking through the range until there are no more matches
            Loop While rFound.Address <> FirstAddress
            On Error GoTo 0
            'For each item found and stored in the collection
            For Each vItem In colUniqueItems
                'Add it to the next listBox
                Me.lstItems.AddItem vItem
            Next vItem
        End If
    End With

End Sub

这是关于 listBox 的一个很好的资源，它展示了如何从数组填充 ListBox以及如何从 ListBox1 到 ListBox2 获取选定的项目等等。