Filtered list only diplaying 1 line in listbox

I have a form that is populating data from a separate spreadsheet which connects to a sharepoint site using a web query.

My script filters the data and returns the results into a listbox.

Everything seems to work fine, but when I filter two fields it will only return a single result and not the list of data. I have stepped through the code and it is filtering correctly, just not displaying the results.

The most confusing thing is I have the exact same code with only one filter on a different page of the form that returns the data correctly.

The working code is:

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

This returns the full list in my listbox 'ActiveListBox', however the below code will only return the first result:

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

回答1:

Looks like David is correct. See this answer on SO.

Here's the summary:

You cannot use a non-contiguous range of cells, so you need to assign the values of those cells to an array first, and then assign the array to the listbox's .List.

Here's the sample provided:

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

回答2:

The copy to another range on another sheet seems best.

Something like:

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