过滤列表仅在列表框中显示 1 行

Question

我有一个表单，它从一个单独的电子表格中填充数据，该电子表格使用网络查询连接到一个共享点站点。

我的脚本过滤数据并将结果返回到列表框中。

一切似乎都很好，但是当我过滤两个字段时，它只会返回一个结果而不是数据列表。我已经单步执行了代码，它可以正确过滤，只是没有显示结果。

最令人困惑的是，我有完全相同的代码，但在表单的不同页面上只有一个过滤器可以正确返回数据。

工作代码是：

Private Sub UpdateActiveButton_Click()

Dim rngVis As Range

Dim Lob As String
Lob = LOBComboBox.Value

Application.ScreenUpdating = False

With Workbooks.Open("Data ssheet")
    With Sheets("Data")

    ActiveSheet.Unprotect
Range("Table_owssvr").ListObject.QueryTable.Refresh BackgroundQuery:=False

        .AutoFilterMode = False

If Lob = "ALL CS" Then

With Intersect(.UsedRange, .Range("A:CM"))
            .Sort Intersect(.Cells, .Parent.Columns("J")), xlAscending, Intersect    (.Cells, .Parent.Columns("A")), , xlAscending, Header:=xlGuess
            .AutoFilter Field:=10, Criteria1:=Array( _
    "CS", "CS2", "CS3"), Operator:=xlFilterValues
            On Error Resume Next
            Set rngVis = .Offset(1).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not rngVis Is Nothing Then Me.ActiveListBox.List = rngVis.Value

            ActiveListBox.ColumnWidths = "33;40;0;0;0;80;50;60;0;130"
        End With


Else


If Lob = "ALL MH&S" Then

With Intersect(.UsedRange, .Range("A:CM"))
            .Sort Intersect(.Cells, .Parent.Columns("J")), xlAscending, Intersect    (.Cells, .Parent.Columns("A")), , xlAscending, Header:=xlGuess
            .AutoFilter Field:=10, Criteria1:=Array( _
    "MHS", "MHS2"), Operator:=xlFilterValues
            On Error Resume Next
            Set rngVis = .Offset(1).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not rngVis Is Nothing Then Me.ActiveListBox.List = rngVis.Value

            ActiveListBox.ColumnWidths = "33;40;0;0;0;80;50;60;0;130"
        End With

       End If        

End With
    .Close False
End With

Application.ScreenUpdating = True

End Sub

这会返回我的列表框“ActiveListBox”中的完整列表，但是下面的代码只会返回第一个结果：

Private Sub CommandButton10_Click()

Dim rngVis2 As Range

Dim Lob2 As String
Lob2 = LOB2ComboBox.Value

Application.ScreenUpdating = False

With Workbooks.Open("data ssheet")
    With Sheets("Data")

    ActiveSheet.Unprotect
Range("Table_owssvr").ListObject.QueryTable.Refresh BackgroundQuery:=False

        .AutoFilterMode = False

If Lob2 = "ALL CS" Then

With Intersect(.UsedRange, .Range("Table_owssvr"))
            .Sort Intersect(.Cells, .Parent.Columns("J")), xlAscending, Intersect(.Cells, .Parent.Columns("A")), , xlAscending, Header:=xlGuess
            .AutoFilter Field:=10, Criteria1:=Array( _
            "CS", "CS2", "CS3"), Operator:=xlFilterValues
            .AutoFilter Field:=2, Criteria1:="Stage 4", Operator:=xlFilterValues
            On Error Resume Next
            Set rngVis2 = .Offset(1).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0

            If Not rngVis2 Is Nothing Then Me.ActiveListBox2.List = rngVis2.Value

            ActiveListBox2.ColumnWidths = "33;40;0;0;0;80;50;60;0;130"

End With

Else


If Lob2 = "ALL MH&S" Then

With Intersect(.UsedRange, .Range("A:CM"))
            .Sort Intersect(.Cells, .Parent.Columns("J")), xlAscending, Intersect(.Cells, .Parent.Columns("A")), , xlAscending, Header:=xlGuess
            .AutoFilter Field:=10, Criteria1:=Array( _
    "MHS", "MHS2"), Operator:=xlFilterValues
           .AutoFilter Field:=2, Criteria1:="Stage 4", Operator:=xlFilterValues
            On Error Resume Next
            Set rngVis2 = .Offset(1).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not rngVis2 Is Nothing Then Me.ActiveListBox2.List = rngVis2.Value

            ActiveListBox2.ColumnWidths = "33;40;0;0;0;80;50;60;0;130"
        End With

        End If            

End With
    .Close False
End With

Application.ScreenUpdating = True

End Sub

Answer 1

看起来大卫是正确的。请参阅 SO 上的 this answer。

总结如下：

您不能使用不连续的单元格范围，因此您需要先将这些单元格的值分配给一个数组，然后将该数组分配给列表框的.List。

这是提供的示例：

Option Explicit

Private Sub CommandButton1_Click()
    Dim Ar() As String
    Dim rng As Range, cl As Range
    Dim i As Long

    Set rng = Range("A1,C1,E1")

    i = 1

    For Each cl In rng
        ReDim Preserve Ar(1, 1 To i)
        Ar(1, i) = cl.Value
        i = i + 1
    Next

    With ListBox1
        .ColumnCount = i - 1
        .ColumnWidths = "50;50;50"
        .List = Ar
    End With
End Sub

Answer 2

复制到另一张纸上的另一个范围似乎最好。

类似：

Sub listit()
    Dim Rng As Range, Cl As Range, RaTo As Range, Ri&, Rl&

    Rl = Range("E65536").End(xlUp).Row  ' end of column "E"

    If Rl > 11 Then    ' only taking from row 11 down to row RL
        Set Rng = ActiveSheet.Range("e11:e" & Rl).SpecialCells(xlCellTypeVisible)
        '
        ' Range to on another sheet  FilteredWork .. as work space only

        Set RaTo = Sheets("FilteredWork").Range("B10").CurrentRegion
        RaTo.ClearContents

        'Rng.Copy RaTo(1, 1)  if one column

        UFJ.ListBox1.ColumnCount = 2

         ' pick what columns of the filtered data you need for what columns of the list
        For Each Cl In Rng
            Ri = Ri + 1
            RaTo(Ri, 1) = Cl(1, 1).Value  ' col "E"
            RaTo(Ri, 2) = Cl(1, -2).Value  ' col "B"
        Next Cl
    End If

    Set RaTo = Sheets("FilteredWork").Range("B10").CurrentRegion  ' find the new data
    UFJ.ListBox1.RowSource = "FilteredWork!" & RaTo.Address

End Sub