从MultiSelect ListBox

Question

有一个与此类似的问题，但它不符合此处的规格。

我有一个MultiSelect ListBox和一个代表AdvancedFilter标准的表。

我想用ListBox中选择的所有值填充此表的“Level”列，每个值应该在一个单独的行中（对于AdvancedFilter是OR条件）。

我正在寻找的结果：

如果未选择任何项目，则应删除表格中添加的行，并仅填充“＆lt;＆gt; 0”。

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

 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

我认为这会做你想要的。根据我关于预加载“＆lt;＆gt; 0”的评论 - 这是不可能的，因为你的数组是单一的。所以你需要陷阱。另外，我调整你的范围来写作，因为在我的模拟中，如果选择了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稍微有点新意，我确信有很多方法可以改进它。

如果您有类似此问题的请求，请随时提出任何问题。