Заполните критерии AdvancedFilter из списка MultiSelect ListBox

Question

Есть вопрос, похожий на этот, но он не соответствует спецификациям.

У меня есть MultiSelect ListBox и таблица, которая представляет критерии AdvancedFilter.

Я хочу заполнитьВ столбце «Уровень» этой таблицы со всеми значениями, выбранными из ListBox, каждое значение должно быть в отдельной строке (условие ИЛИ для AdvancedFilter).

Результаты, которые я ищу:

Еслиэлемент не выбран, он должен удалить строки, добавленные в таблицу, и заполнить только «<> 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

Это выглядит сложно, но делает работу аккуратно.

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, я уверен, что есть множество способов улучшить его.

Если у вас есть запрос, похожий на этот вопрос, не стесняйтесь задавать любые вопросы.

Answer 2

Я думаю, что это будет делать то, что вы хотите.Согласно моему комментарию о предварительной загрузке с «<> 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