已篩選的列表僅在列表框中顯示1行

Question

我有一個表單，它是通過使用Web查詢連接到SharePoint站點的單獨電子表格填充數據。

我的腳本過濾數據並將結果返回給列表框。

一切似乎工作正常，但是當我過濾兩個領域，它只會返回一個單一的結果，而不是數據列表。我已經完成了代碼並正確過濾，只是沒有顯示結果。

最令人困惑的是我有完全相同的代碼，只有一個過濾器在正確返回數據的不同頁面上。

工作代碼爲：

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