已筛选的列表仅在列表框中显示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