Home » excel » excel – Populate AdvancedFilter Criteria from a MultiSelect ListBox

excel – Populate AdvancedFilter Criteria from a MultiSelect ListBox

Posted by: admin May 14, 2020 Leave a comment

Questions:

There is a question similar to this one but it does not meet the specifications here.

I have a MultiSelect ListBox and a table which represents an AdvancedFilter criteria.

I want to populate the column “Level” of this table with all the values selected from the ListBox, every value should be in a separate row (OR condition for an AdvancedFilter).

The results I am seeking :

enter image description here
enter image description here

enter image description hereenter image description here

If no item is selected, it should remove the rows added in the table and only populate “<>0”.

enter image description hereenter image description here

The code I have written so far does the tricks shown in the 2 first images but and when I deselect all the items it does not work anymore:

 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

Has someone already dealt with this issue? Any help would be much appreciated! Thank you so much!

How to&Answers:

I think this will do what you want. As per my comment about preloading with “<>0” – that’s not possible because your array is a Single. So you need to trap it. Also, I tweaked your range to write to as in my mock up I kept getting a zero on the end if 1 or more were selected.

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:

It looks complicated, but it does the job neatly.

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

If you have an improvement to my code, i will gladly take it! I am slightly new to VBA, i’m sure there are tons of ways to improve it.

If you have a request similar to this issue, feel free to ask any question.