adding items to an array

Difficult to comment with out seeing the entire code.

Try

If InStr(UCase(Range(CatCol & j)), UCase(MyArray(i)))>0 Then

that didn't solve it, here iss the rest of the code

part that populates the listbox

       'Creates Catalog List
            Set dic = CreateObject("Scripting.Dictionary")
            For Each r In Range(CatCol & "2", Range(CatCol & Rows.Count).End(xlUp))
                If r.Value <> "" Then
                    For Each e In Split(r.Value, ",")
                        dic(StrConv(Trim$(e), 3)) = Empty
                    Next
                End If
            Next
            Me.ListBox1.List = dic.keys

code that autofilters the rows

   'Get Listbox Data
        Dim i As Integer
        Dim j As Long
        
        Dim MyArray As Variant
    ReDim MyArray(0)
    
    For i = 0 To ListBox1.ListCount - 1
        If Me.ListBox1.Selected(i) Then
            MyArray(UBound(MyArray)) = UCase(Me.ListBox1.List(i))
            ReDim Preserve MyArray(UBound(MyArray) + 1)
        End If
    Next i
               
 'test variables
Dim msg As String
Dim cellv As String


    'Skips filtering if "All Items" are selected
        If ListSelect <> "All Items" And ListBox1.Visible <> False Then
        
    'Filters the sheet based on selection

        Set rng = Range(CatCol & "1:" & CatCol & LastRow)
       
        For j = 1 To LastRow
        
        
        cellv = UCase(Range(CatCol & j))
            
            For i = LBound(MyArray) To UBound(MyArray)
                If Not IsEmpty(MyArray(i)) Then
                    If InStr(UCase(Range(CatCol & j)), UCase(MyArray(i))) Then
                        If UCase(Range(CatCol & j)) <> UCase(MyArray(i)) Then
                            MyArray(UBound(MyArray)) = Range(CatCol & j)
                            ReDim Preserve MyArray(UBound(MyArray) + 1)
                        End If
                    End If
                End If
                
            Next i
        Next j
        
'test
msg = ""
For i = LBound(MyArray) To UBound(MyArray)
    msg = msg & MyArray(i) & vbNewLine
Next i
MsgBox "the values of my dynamic array are: " & vbNewLine & msg
MsgBox UBound(MyArray) - LBound(MyArray) + 1

        
        rng.AutoFilter Field:=1, Criteria1:=MyArray, Operator:=xlFilterValues, visibledropdown:=False
    Application.ScreenUpdating = True
        End If



Unload Me


End Sub

This will not solve either

If InStr(UCase(Range(CatCol & j)), UCase(MyArray(i)))=0 Then

as dog, mouse is found twice.
If you use dictionary and split function as you will have the same issue as dogs appeared three times, but if you treat each (row) cell value, you will get unique rows.
Like

Sub tets()
   Dim MyArray As Variant
ReDim MyArray(0)
 Set Rng = Range(CatCol & "1:" & CatCol & LastRow)
 'Set Rng = Range("A1:A6")
'Creates Catalog List
            Set dic = CreateObject("Scripting.Dictionary")
            For Each r In Rng
                If r.Value <> "" Then
                  dic(Trim(r)) = Empty
                End If
            Next
            V = dic.keys
            
'            For Each V In dic.keys
'              Z = V
'            Next
            
End Sub

I tested it and it works. The only issue you have is what are going to do with unique values. I stored them in array V

it was done like that to simplify the list box for the user. the user just sees "cat, dog, mouse" that they can select but that information cannot be passed to the autofilter because you cannot filter part of the cell contents and you are limited by the number of criteria you can put in an autofilter. Hence why the second part loops through the cells to add all those different strings that contain the selection to then pass to the autofilter. the second part should be looping through and only adding unique values, but it seems to be adding non unique values as well which then have to be looped through and causes the macro to take more time than necessary. I cannot figure out why it's adding non unique values.

I have provided you a solution, you can pass the unique values to filter

For Each V In dic.keys
' filter Z = V
' Next
to filter unique values

it works but the user would need to select all the different combinations that contained "dog" in it, unless i'm missing something here.

The code merely selects the unique rows.

cat, dog, mouse
cat, mouse
dog, mouse
dog
Not much.
If you want to select a combination of dogs. For example, all with dogs, you can use normal filter with dogs and star, but only 2 stars in one line.
I probably did not understand your request. If you use dictionary with split function, you end up with unique values(Dog, cat and mouth). If you use dictionary WITH OUT split function, you get 4 unique rows as shown above, but as a unit.

The first part of the code breaks it down so the user has 3 options "cat, dog, mouse" the second part then loops through the column when dog is selected and add the cells that contain "dog" so the array should be "cat, dog, mouse", "dog, mouse", "dog" to then pass to the filter so it can filter the proper rows. The original code works and gives the desired results but when I look at the contents of the array, instead of having 3 entries it adds duplicates and I end up with thousand of entries in the array. So I believe the problem is with this section of code that is supposed to add only unique values back to the array

        For j = 1 To LastRow
        
        
        cellv = UCase(Range(CatCol & j))
            
            For i = LBound(MyArray) To UBound(MyArray)
                If Not IsEmpty(MyArray(i)) Then
                    If InStr(UCase(Range(CatCol & j)), UCase(MyArray(i))) Then
                       If UCase(Range(CatCol & j)) <> UCase(MyArray(i)) Then
                            MyArray(UBound(MyArray)) = Range(CatCol & j)
                            ReDim Preserve MyArray(UBound(MyArray) + 1)
                        End If
                    End If
                End If
                
            Next i
        Next j

You still have not defined what is a unique value.
The code you have will not give what you are looking for.

Look at this code which is the same as you have.

Sub minecountme()

Dim str1, str2, Cel, Mycount1, Mycount2
For Each Cel In Range("A1:A6")
    If InStr(1, str1, Cel) = 0 Then
        str1 = str1 & Cel
         Mycount1 = Mycount1 + 1
'    ElseIf InStr(1, str2, Cel) = 0 Then
'           str2 = str2 & Cel
'           Mycount2 = Mycount2 + 1
    End If
Next
Range("B1") = Mycount1

End Sub

will give 2 unique rows

a unique value is any cell that contains "dog" but is not already in the array. so if "dog, cat" is in the array already, the next cell that contains "dog, cat" should be skipped and not added to the array a second time

Originally Posted by Code Flunkie

a unique value is any cell that contains "dog" but is not already in the array. so if "dog, cat" is in the array already, the next cell that contains "dog, cat" should be skipped and not added to the array a second time

What about "cat, dog" ?

"cat,dog" would be a unique value as well.

a2 = cat, dog, mouse
a3 = cat, mouse
a4 = dog, mouse
a5 =dog
a6 =dog

if user selects "dog" the array cycles through the cells that contain dog and should add them to the array. so a2, a4, a5 should be added.
Is it a fixed value, that is "dog" only? If it is not and could be any combination of values, it will require a separate and long code.
I am off the site shortly and hopefully some one will help you.

Originally Posted by Code Flunkie

I have a listbox that breaks down a comma delimited list from a single column and lists the individual items for a user to select, which is then fed back to an autofilter to hide the rows that don't contain the items anywhere in the cell. ie

a2 = cat, dog, mouse
a3 = cat, mouse
a4 = dog, mouse
a5 =dog
a6 =dog

if user selects "dog" the array cycles through the cells that contain dog and should add them to the array. so a2, a4, a5 should be added. a6 should be ignored because it would already be in the array. my code seems to be adding a6 as well so it seems to slow the code down because it's adding to many duplicates. i'm sure it's a simple syntax error on my part but i cant seem to find it. any help would be awesome.

Adjust this

    With Range("a2", Range("a" & Rows.Count).End(xlUp))
        myArray = Filter(.Parent.Evaluate("transpose(if((countif(offset(" & .Address & ",,,row(1:" & .Rows.Count & "))," & _
                .Address & ")=1)*(isnumber(search(""dog""," & .Address & ")))," & .Address & "))"), False, 0)
    End With
    MsgBox Join(myArray, vbLf)

figured it out, here is my code for others to use

Private Sub CommandButton1_Click()
       
    Dim rng As Range
    Dim LastRow As Long
    Dim i As Integer
    Dim j As Integer
    Dim v As Variant
    Dim bMatch As Boolean
    Dim MyArray As Variant
    
    Application.ScreenUpdating = False
    
        ActiveSheet.Cells.EntireRow.Hidden = False
        If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData
        
        
    ' Find Last Used Row
        
        LastRow = ActiveSheet.Range(SKU & Rows.Count).End(xlUp).Row
        
     
    'Get Listbox Data for filter
       
        ReDim MyArray(0)
        
        For i = 0 To ListBox1.ListCount - 1
            If Me.ListBox1.Selected(i) Then
                MyArray(UBound(MyArray)) = UCase(Me.ListBox1.List(i))
                ReDim Preserve MyArray(UBound(MyArray) + 1)
            End If
        Next i


    'Skips filtering if "All Items" are selected
        
        If ListSelect <> "All Items" And ListBox1.Visible <> False Then
        
        
    'Filters the sheet based on selection

        Set rng = Range(CatCol & "1:" & CatCol & LastRow)
       
        'Loop through rows
        For j = 1 To LastRow
        
            'Loop through array to find match
            For i = LBound(MyArray) To UBound(MyArray)
                
                If Not IsEmpty(MyArray(i)) Then
                    
                    If InStr(UCase(Range(CatCol & j)), UCase(MyArray(i))) Then
                      
                        bMatch = False
                        For Each v In MyArray
                        
                        If StrComp(CStr(v), Range(CatCol & j).Value, vbTextCompare) = 0 Then
                        bMatch = True
                        End If
                        Next
                            
                            'adds to array if not an exact match
                            If Not bMatch Then
                            
                            MyArray(UBound(MyArray)) = Range(CatCol & j)
                            ReDim Preserve MyArray(UBound(MyArray) + 1)
                            End If
                       
                    End If
                End If
            Next i
        Next j
        
        
        'Filters worksheet based on selection
            rng.AutoFilter Field:=1, Criteria1:=MyArray, Operator:=xlFilterValues, visibledropdown:=False
            
    
        End If

    Application.ScreenUpdating = True

    Unload Me


End Sub