Autofilter in VBA when criteria is has more words separated by a comma in 2 sheets

[shafiey]

Hello
I don't know coding. I want to write the following VBA code for a condition whose Criteria1 is in cell D1 in another sheet. please guide me.
Thank you very much for your effort.
Data sheet is in "Projects" sheet and in table= "projectstbl" and Data column= AC column, Field= 29, Header=1st row, Table Range= A2:AQ2100
Criteria is in "keywords analysis" sheet, D1 cell

VBA Code:

Sub MaterialWise()
    
    ' Define constants.
    Const TableName As String = "projectstbl"
    Const CriteriaCellAddress As String = "D1"
    Const Delimiter As String = ", "
    Const CriteriaColumn As Long = 4
    
    ' Reference the worksheet ('ws').
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    ' Reference the table ('tbl').
    Dim tbl As ListObject: Set tbl = ws.ListObjects(TableName)
    ' Reference the Criteria cell ('cCell').
    Dim cCell As Range: Set cCell = ws.Range(CriteriaCellAddress)
    
    ' Using the Split function, write the criteria strings
    ' to the Criteria array ('cArr'), a 1D zero-based array.
    Dim cArr() As String: cArr = Split(CStr(cCell.Value), Delimiter)
    
    ' Clear table filters.
    With tbl
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
    End With
    
    Dim FoundMore As Boolean
    
    ' Handle up to two criteria...
    
    With tbl.Range
        Select Case UBound(cArr)
        Case Is < LBound(cArr) ' blanks
            .AutoFilter CriteriaColumn, ""
        Case 0 ' 1 criterion
            .AutoFilter CriteriaColumn, "*" & cArr(0) & "*"
        Case 1 ' 2 criteria
            .AutoFilter CriteriaColumn, _
                "*" & cArr(0) & "*", xlOr, "*" & cArr(1) & "*"
        Case Else
            FoundMore = True
        End Select
    End With
    
    If Not FoundMore Then Exit Sub
    
    ' Handle more than two criteria...
    
    ' Write the values from the column to the Data array ('Data'),
    ' a 2D one-based one-column array.
    Dim Data() As Variant
    With tbl.DataBodyRange.Columns(CriteriaColumn)
        If .Rows.Count = 1 Then ' one cell
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else ' multiple cells
            Data = .Value
        End If
    End With
    
    ' Create and reference a new dictionary object ('dict').
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    ' Write the Criteria array's upper limit to a variable ('cUpper')
    ' since it's going to be used in a loop.
    Dim cUpper As Long: cUpper = UBound(cArr)
    
    ' Declare additional variables.
    Dim r As Long ' Data Array Row Counter
    Dim c As Long ' Criteria Array Elements Counter
    Dim cString As String ' Current String in Data Array
    
    ' Write the unique strings in the Data array, meeting any of the criteria,
    ' to the 'keys' of the dictionary.
    For r = 1 To UBound(Data, 1)
        cString = CStr(Data(r, 1))
        For c = 0 To cUpper
            If InStr(1, cString, cArr(c), vbTextCompare) > 0 Then Exit For
        Next c
        If c <= cUpper Then dict(cString) = Empty
    Next r
    
    ' Filter the table by the 'keys' of the dictionary.
    tbl.Range.AutoFilter CriteriaColumn, dict.Keys, xlFilterValues

End Sub