如何将可见单元格（应用自动过滤器后）分配给列表框？

Question

想象一下，在应用过滤器后，我们有一个列表框和许多可见单元格。

我想在列表框中显示可见单元格。

我尝试将这些单元格复制到某个数组中，然后使用该数组使用.list<\/code>属性填充列表框。

With Worksheets("Sheet1")
    
    '' LastRow = 101 because I have a table of data with 101 rows (including headers )and 6 columns 
    LastRow = Cells(Rows.count, 1).End(xlUp).Row
    
    '' lastCol = 6 because I have a table of data with 101 rows and 6 columns 
    lastCol = Cells(1, Columns.count).End(xlToLeft).Column
    
    Dim arr1()
    
    i = 0
    j = 0
    
    Dim s As Range
    Set s = .Range("A2:F" & LastRow).SpecialCells(xlCellTypeVisible)
    '' s contains the visible cells after autofilter 
    
    ncol = s.Columns.count
    
    nrow = Application.WorksheetFunction.Subtotal(2, .Range("A2:A" & .Rows(.Rows.count).End(xlUp).Row))
    '' nrow is the number of visible rows in the s range 
    
    MsgBox "lastrow " & LastRow
    MsgBox "ncol is " & ncol
    MsgBox "nrow" & nrow
    
    ReDim arr1(1 To nrow, 1 To ncol)
    
    '' counters to loop through the array arr1
    Dim Currentrow
    Dim Currentcol
    Currentrow = 1
    Currentcol = 1
    
    On Error Resume Next
    
    For Each cell In .Range("A2:F" & LastRow).SpecialCells(12)
        While (Currentrow < nrow)
            For Currentcol = 1 To ncol
                arr1(Currentrow, Currentcol) = cell
                MsgBox arr1(Currentrow, Currentcol)
            Next
            Currentrow = Currentrow + 1
        Wend
    Next
    
    On Error GoTo 0
    
    ''arr1 = s.Value
    
    UserForm1.ListBox2.list = arr1
End With

Answer 1

Get Filtered Data

Standard Module eg Module1

Option Explicit

Sub LoadData()
    
    Const CritCol As Long = 1
    Const Criteria As String = "No"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    
    Dim dData As Variant: dData = GetFilteredData(ws, CritCol, Criteria)
    If IsEmpty(dData) Then Exit Sub
    
    Dim cCount As Long: cCount = UBound(dData, 2) ' - LBound(dData, 2) + 1
        
    With UserForm1.ListBox2
        .Clear
        .ColumnCount = cCount
        .List = dData
    End With

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a filtered range in a 2D one-based array.
' Remarks:      The range has to be a contiguous range starting in cell 'A1'.
'               Any filters in the worksheet may be permanently removed.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFilteredData( _
    ByVal ws As Worksheet, _
    ByVal CriteriaColumn As Long, _
    ByVal Criteria As String) _
As Variant
    If ws Is Nothing Then Exit Function ' no worksheet
    If CriteriaColumn < 1 Then Exit Function ' allow only positive
    
    If ws.AutoFilterMode Then
        ws.AutoFilterMode = False
    End If
    
    Dim trg As Range: Set trg = ws.Range("A1").CurrentRegion
    If trg.Rows.Count = 1 Then Exit Function ' only one row
    
    Dim cCount As Long: cCount = trg.Columns.Count
    If CriteriaColumn > cCount Then Exit Function ' too few columns
    
    Dim crg As Range: Set crg = trg.Columns(CriteriaColumn)
    Dim frg As Range: Set frg = trg.Resize(trg.Rows.Count - 1, 1).Offset(1)
         
    crg.AutoFilter 1, Criteria
    
    On Error Resume Next
    Dim ffrg As Range: Set ffrg = frg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    ws.AutoFilterMode = False
    If ffrg Is Nothing Then Exit Function ' no match
    
    Dim rCount As Long: rCount = ffrg.Cells.Count
    Dim jData As Variant: ReDim jData(1 To rCount)
    
    Dim ffCell As Range
    Dim r As Long
    For Each ffCell In ffrg.Cells
        r = r + 1
        jData(r) = ffCell.Resize(, cCount).Value
    Next ffCell
    
    Dim dData As Variant: ReDim dData(1 To rCount, 1 To cCount)
    
    Dim c As Long
    For r = 1 To rCount
        For c = 1 To cCount
            dData(r, c) = jData(r)(1, c)
        Next c
    Next r
    
    GetFilteredData = dData

End Function

UserForm Module eg UserForm1

Option Explicit

Private Sub UserForm_Initialize()
    LoadData
End Sub