Question

我在Sheet2中有数据，如下所示 实际数据

然后我手动将文件管理器应用于那些看起来像......的数据 过滤数据

我在表单中有一个用户表单（UserForm1）和一个列表框（ListBox1）。还有一个命令按钮cmdFilteredData。所以，我想只用过滤后的数据填充列表框。我在下面的代码中提出了Type mismatch错误。

Private Sub cmdFilteredData_Click()
Dim FilteredRange As Range
    Set FilteredRange = Sheet2.Range("A1:C5").Rows.SpecialCells(xlCellTypeVisible)

    With Me.ListBox1

        .ColumnCount = 3
        .MultiSelect = fmMultiSelectExtended
        .RowSource = FilteredRange
    End With

End Sub

任何帮助都是衷心的。

Answer 1

替代功能 - 不可靠 - SpecialCells（xlCellTypeVisible）

这个答案旨在完成 Shai Rado的赞赏解决方案，而不是纠正它。

测试上述解决方案但显示使用SpecialCells(xlCellTypeVisible)和/或引用CurrentRegion可能会导致问题（即使在OP的小范围内）。
函数（尤其是udfs）的可能解决方法在SpecialCells(xlCellTypeVisible) not working in UDF处提供。

Private Function VisibleCells(rng As Range) As Range
' Site: https://stackoverflow.com/questions/43234354/specialcellsxlcelltypevisible-not-working-in-udf
' Note: as proposed by CalumDA
Dim r As Range
For Each r In rng
    If r.EntireRow.Hidden = False Then
        If VisibleCells Is Nothing Then
            Set VisibleCells = r
        Else
            Set VisibleCells = Union(VisibleCells, r)
        End If
    End If
Next r
End Function

Shai Rado的解决方案略有修改（参见上面的注释）

在任何情况下，目标范围必须在复制前清除，然后在没有 CurrentRegion的情况下更好地引用，这样您才能获得所需的项目。这些变化对我有用。

Option Explicit Private Sub cmdFilteredData_Click() Dim ws As Worksheet Dim sRng As String Dim FilteredRange As Range Dim myArr As Variant Dim n As Long Set ws = ThisWorkbook.Worksheets("Filtered") n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row ' get last row sRng = "A1:C" & n ' Set FilteredRange = ws.Range(sRng).SpecialCells(xlCellTypeVisible) ' << not reliable Set FilteredRange = VisibleCells(ws.Range(sRng)) ' <<<< possible ALTERNATIVE ' clear target range in order to allow correct array fillings later ! ws.Range("Z:AAB").Value = "" ' copy filtered range to the columns on the right FilteredRange.Copy ws.Range("Z1") ' populate the array with new range values (without blank rows in the middle) ' myArr = ws.Range("Z1").CurrentRegion ' sometimes unreliable, too myArr = ws.Range("Z1:AAB" & ws.Range("Z" & ws.Rows.Count).End(xlUp).Row) ' <<< better than CurrentRegion With Me.ListBox1 .ColumnCount = 3 .MultiSelect = fmMultiSelectExtended .List = (myArr) End With End Sub

引用帖子中提到的链接：

Microsoft - udf not working

ExcelForum - xlCelltypeVisible not working

MrExcel - SpecialCells not working

Answer 2

由于您尝试使用过滤范围中的值填充ListBox1，因此中间有空白行，这是＆＃34;混乱＆＃34;向上ListBox。

相反，您可以复制＆gt;＆gt;将值粘贴到右侧（或其他工作表）的列中，使用数组填充这些值，然后使用数组填充ListBox1。

<强>代码

Private Sub cmdFilteredData_Click()

Dim FilteredRange As Range
Dim myArr As Variant

Set FilteredRange = ThisWorkbook.Sheets("Sheet8").Range("A1:C5").SpecialCells(xlCellTypeVisible)

' copy filtered range to the columns on the right (if you want, you can add a "Dummy" sheet), to have the range continous
FilteredRange.Copy Range("Z1")

' populae the array with new range values (without blank rows in the middle)
myArr = Range("Z1").CurrentRegion

With Me.ListBox1
    .ColumnCount = 3
    .MultiSelect = fmMultiSelectExtended
    .List = (myArr)
End With

End Sub

Answer 3

我为此搜索了很多，但如果不将数据粘贴到工作表中，我无法找到任何优雅的解决方案。所以我创建了自己的函数来将范围的可见单元格转换为数组。

也许这不是最聪明的方法，但效果很好，而且速度很快。

Function createArrFromRng(rng As Range)
Dim sCellValues() As Variant
Dim col, row, colCount, RowCount As Integer

col = 0
row = 0
colCount = 0
RowCount = 0

On Error GoTo theEnd
Set rng = rng.SpecialCells(xlCellTypeVisible)

'get the columns and rows size
For Each cell In rng

    If col < cell.Column Then
        colCount = colCount + 1
    Else
        colCount = 1
    End If
    col = cell.Column
    
    If row < cell.row Then
        RowCount = RowCount + 1
    End If
    row = cell.row

Next cell

'set the array size
ReDim Preserve sCellValues(RowCount - 1, colCount - 1)
col = 0
row = 0
colCount = 0
RowCount = 0

'get the values and add to the array
For Each cell In rng

    If col < cell.Column Then
        colCount = colCount + 1
    Else
        colCount = 1
    End If
    col = cell.Column
    'Debug.Print colCount
    
    If row < cell.row Then
        RowCount = RowCount + 1
    End If
    row = cell.row

    sCellValues(RowCount - 1, colCount - 1) = cell.value

Next cell

theEnd:
createArrFromRng = sCellValues

End Function

如何将过滤后的数据作为多列列表框的行源？

3 个答案: