从 MultiSelect ListBox 填充 AdvancedFilter Criteria

Question

有个类似这个的问题，但是不符合这里的规范

我有一个 MultiSelect ListBox 和一个代表 AdvancedFilter 条件的 table。

我想用从 ListBox 中选择的所有值填充这个 table 的列 "Level"，每个值都应该在单独的行中（AdvancedFilter 的 OR 条件）。

我要的结果：

如果没有选择任何项目，它应该删除在 table 中添加的行并且只填充“<>0”。

到目前为止我编写的代码实现了前两张图片中显示的技巧，但是当我取消选择所有项目时它不再起作用：

 Private Sub ListBox1_LostFocus()

    Dim aArray() As Single
    ReDim aArray(1 To 1) As Single
    With ListBox1
        For I = 0 To .ListCount - 1
            If .Selected(I) Then
            aArray(UBound(aArray)) = .List(I)
            ReDim Preserve aArray(1 To UBound(aArray) + 1) As Single
        End If
        Next I
        End With

 Range(Cells(3, "S"), Cells(UBound(aArray) - 1, "S"))= Application.Transpose(aArray)

End Sub

有人处理过这个问题吗？任何帮助将非常感激！非常感谢！

Answer 1

我想这会做你想要的。根据我关于使用“<>0”预加载的评论 - 这是不可能的，因为您的数组是 Single。所以你需要捕获它。此外，我调整了您要写入的范围，因为在我的模型中，如果选择了 1 个或更多，我会在最后得到一个零。

Dim aArray() As Single
ReDim aArray(1 To 1) As Single

With ListBox1
    For I = 0 To .ListCount - 1
        If .Selected(I) Then
            aArray(UBound(aArray)) = .List(I)
            ReDim Preserve aArray(1 To UBound(aArray) + 1) As Single
        End If
    Next I
End With

Range("S3:S10").ClearContents ' change this range to suit

If UBound(aArray) = 1 Then
    Range("S3") = "<>0"
Else
    Range(Cells(3, "S"), Cells(3 + UBound(aArray) - 2, "S")) = Application.Transpose(aArray)
End If

Answer 2

看起来很复杂，但做起来很巧妙。

Private Sub ListBox1_LostFocus()
'
'is called when you finish selecting items from the ListBox
'

    Dim aArray() As Single
    ReDim aArray(1 To 1) As Single

    'fetch selected items of listbox into aArray
    With ListBox1
        For I = 0 To .ListCount - 1
            If .Selected(I) Then
                aArray(UBound(aArray)) = .List(I)
                ReDim Preserve aArray(1 To UBound(aArray) + 1) As Single
            End If
        Next I
    End With

    'clear old items in the advanced filter's condition table to replace them with those we fetched
    '/!\ if there was more old items than new items, we would need to delete their rows from the table
    Range("Condition[Level]").ClearContents

    'we need to compare the size of the array with the size of the table so that we don't have extra rows
    '(the advanced filter interpretates empty rows as '*' so we absolutely need to get rid of them)
    r = UBound(aArray)
    n = Range("Condition[#Data]").Rows.count


    If UBound(aArray) = 1 Then
        Range("Condition[Level]") = "<>0" 'if nothing is selected, fetch every item meaning numeric and non numeric (more powerful than "*")
        Range("Condition[Serial]") = "*" 'columns to the left of 'Level' are not automatically replicated in the table (contrary to those on the right which gets previous row's) values so they become empty, that's why we need to fill them with the value we want
        Range("Condition[#Data]").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    Else
        Range(Cells(3, "S"), Cells(3 + UBound(aArray) - 2, "S")) = Application.Transpose(aArray)

        If n > r - 1 Then
            [Condition].Rows(r & ":" & n).Select ' r+1 to skip the headers' row
            [Condition].Rows(r & ":" & n).Delete 'doing a select before the delete prevents a bug which would delete the entire rows of the sheet
        End If

    End If

如果你对我的代码有改进，我很乐意采纳！我对 VBA 有点陌生，我相信有很多方法可以改进它。

如果您有类似此问题的需求，欢迎随时提问。

从 MultiSelect ListBox 填充 AdvancedFilter Criteria

Populate AdvancedFilter Criteria from a MultiSelect ListBox

excel

vba

listbox

multi-select

advanced-filter