Filter out column based on multiple selection listbox

Devil_717

New Member
Joined
Oct 22, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
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!

VBA Code:
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
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,562
Office Version
  1. 365
Platform
  1. Windows
Hi & welcome to MrExcel.
Are you trying to hide the values you selected in the listbox?
 

Devil_717

New Member
Joined
Oct 22, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,562
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
VBA Code:
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
 
Solution

Devil_717

New Member
Joined
Oct 22, 2020
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Sorry for late reply.

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

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,562
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,587
Messages
5,637,236
Members
416,963
Latest member
samfuge

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top