Filter out column based on multiple selection listbox

[Devil_717]

Hello everyone,

I'm VBA newbie. What I want to do is filter out column with multiple criteria based on listbox selection. I have a script that is working, but whenever I deselect all the options I get "Run-time error '13': Type mismatch" on line: "ReDim finalArray(LBound(allArray) To Abs(UBound(consArray) - UBound(allArray)) - 1)". Listbox is populated automatically with unique values from filtered column. Name of the column I'm filtering is "Consequence" ("U"). I tried things like "If IsEmpty(finalArray) Then Exit Sub", but with no luck. I will greatly appreciate your help!

Private Sub ListBox_Change()

    Dim consArray As Variant
    Dim allArray As Variant
    Dim finalArray As Variant
    Dim myMsg As String
    Dim i As Long
    Dim Count As Integer
    Dim findCell As Range
    Dim coll As Collection

    Count = 0

    For i = 0 To ListBox.ListCount - 1
        If ListBox.Selected(i) Then
            If Count = 0 Then
                ReDim consArray(Count)
            Else
                ReDim Preserve consArray(Count)
            End If
            consArray(Count) = ListBox.List(i)
            Count = Count + 1
        End If
    Next i

    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    vData = Range("U2:U100000")
    For i = LBound(vData) To UBound(vData)
        If vData(i, 1) <> "" Then dic(vData(i, 1)) = Empty
    Next i
    allArray = dic.keys

        ReDim finalArray(LBound(allArray) To Abs(UBound(consArray) - UBound(allArray)) - 1)

    Set coll = New Collection
    For i = LBound(allArray) To UBound(allArray)
        coll.Add allArray(i), allArray(i)
    Next i
    For i = LBound(consArray) To UBound(consArray)
        On Error Resume Next
        coll.Add consArray(i), consArray(i)
        If Err.Number <> 0 Then
            coll.Remove consArray(i)
        End If
        On Error GoTo 0
    Next i
    For i = LBound(finalArray) To UBound(finalArray)
    finalArray(i) = coll(i + 1)
    Debug.Print finalArray(i)
    Next i

    With ActiveSheet
        Set findCell = .Cells.Find(What:="Consequence", After:=Range("A1"))
        actCol = findCell.Column
        .Range(Selection, Selection.End(xlUp)).AutoFilter Field:=actCol, Criteria1:=finalArray, Operator:=xlFilterValues
    End With

End Sub

 

[Fluff]

Hi & welcome to MrExcel.
Are you trying to hide the values you selected in the listbox?

 

[Devil_717]

Yes, that's exactly what I want to do. The script works - selected values are hidden, but when I'm clearing the selection, it shows the error.

 

[Fluff]

Ok, how about

Private Sub ListBox_Change()
   Dim DicEx As Object
   Dim vData As Variant, FilterAry As Variant
   Dim i As Long
   Dim Fnd As Range
   
   Set DicEx = CreateObject("scripting.dictionary")
   DicEx.CompareMode = 1
   With ListBox
      For i = 0 To .ListCount - 1
         If .Selected(i) Then
            DicEx.Add .List(i), Nothing
         End If
      Next i
   End With
   With CreateObject("Scripting.Dictionary")
      .CompareMode = vbTextCompare
      vData = Range("U2:U100000")
      For i = LBound(vData) To UBound(vData)
         If vData(i, 1) <> "" And Not DicEx.Exists(vData(i, 1)) Then .Item(vData(i, 1)) = Empty
      Next i
      FilterAry = .Keys
   End With

   With ActiveSheet
       Set Fnd = .Cells.Find(What:="Consequence", After:=Range("A1"))
       .Range("A1:U1").AutoFilter Field:=Fnd.Column, Criteria1:=FilterAry, Operator:=xlFilterValues
   End With
End Sub

 

[Devil_717]

Sorry for late reply.

Your solution worked like a charm, thank you very much!

 

[Fluff]

You're welcome & thanks for the feedback.