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!
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