VBA - 从多个 ListObjects 填充 ListBox

Question

我正在尝试使用来自多个 ListObjects 的条目填充 ListBox。 但并非所有条目都应填充，只有在 ListObject 的列中具有特定值的条目才应填充。

示例： ListObjects 由 3 列组成：[Name]、[Size]、[Position]

如果 [Position] 列中的值为“Top”，则从 ListObject1 到 ListObject5 的所有条目都应填充到 ListBox。

基于该结果的下一个问题： 然后，我如何在第二个 ListBox 中显示 [Position] 不是“Top”的依赖 ListObject 的所有条目。 换句话说，并非所有 ListObjects 中不是“Top”的所有条目都应该显示在第二个 LIstBox 中，只有来自特定 ListObject 的那些可能的条目显示在第一个 ListBox 中选取的值匹配。

我的想法可能很奇怪，但是如何创建一个全新的表（可能是一个数组），它包含所有 ListObjects 中的所有条目，这些条目将在打开 UserForm 时生成，然后向其中添加第三列 - [ListObjectNumber ] - 包含该信息来自哪个 Table 的信息，这将有助于第二个 ListBox 仅显示正确的条目...但这可能太超前了。

感谢您的帮助！

Answer 1

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

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

• 在此示例中添加了 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 的一个很好的资源，它展示了如何 populate ListBox from an Array 以及如何从 ListBox1 到 ListBox2 中获取所选项目等等。