Find data and move to prior cell and find again using active cell value - problems faced

Question

Its update to my prior question for which i missed to add point saying that column 3 Header data might start with space or at the end or any additional text in it hence we should try it with contains.

Count results should be shown in a new sheet for all filter entities like 3 (Index) 3(Level) AIUH (Entity Name) 3(Count) with additional column to the end of the table and rows will not be

I apologize for my bad etiquette and wasting experts time on this to work again.

Here is the previous code for reference:

Sub xferAscendingFiltered()
Dim cnt As Long, rHDR As Range, rDELs As Range, vFLTRs As Variant

'fill this array with your 40-50 Header values
vFLTRs = Array("AIS", "BBS", "AIUH", _
               "XXX", "YYY", "ZZZ")

With Worksheets("Sheet2")
    If .AutoFilterMode Then .AutoFilterMode = False
    With .Cells(1, 1).CurrentRegion
        'filter on all the values in the array
        .AutoFilter Field:=3, Criteria1:=vFLTRs, Operator:=xlFilterValues

        'walk through the visible rows
        With .Resize(.Rows.Count - 1, 1).Offset(0, 2)
            Set rHDR = .Find(What:=Chr(42), After:=.Cells(1, 1), _
                             SearchOrder:=xlByRows, SearchDirection:=xlNext)
            'seed the rows to delete so Union can be used later
            If rHDR.Row > 1 Then _
                Set rDELs = rHDR

            Do While rHDR.Row > 1

                cnt = 0
                'increase cnt by both visible and hidden cells
                Do
                    cnt = cnt + 1
                Loop While rHDR.Offset(cnt, -1).Value2 > rHDR.Offset(cnt - 1, -1).Value2 And _
                           Intersect(rHDR.Offset(cnt, 0), .SpecialCells(xlCellTypeVisible)) Is Nothing

                'transfer the values and clear the original(s)
                With .Cells(rHDR.Row, 1).Resize(cnt, 3).Offset(0, -2)
                    'transfer the values
                    Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
                    'set teh count
                    Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1 - cnt, 3) = cnt
                    Set rDELs = Union(rDELs, .Cells)
                    rHDR.Clear
                End With

                'get next visible Header in column C
                Set rHDR = .FindNext(After:=.Cells(1, 1))
            Loop
            .AutoFilter
        End With

    End With

    'remove the rows
    rDELs.EntireRow.Delete

End With

End Sub

Prior question link:

Thanks experts

Answer 1

Wildcards in your filter code.

To use contains using a variable, this should work as the criteria to find:

This will loop through the array and place a 1 beside a match, then filter column D for 1

Sub xferAscendingFiltered()

    Dim cnt As Long, rHDR As Range, rDELs As Range, vFLTRs As Variant
    '-------------
    Dim rng As Range, cel As Range, LstRw As Long, sh As Worksheet, i    '<<<<<

    Set sh = Sheets("Sheet2")    '<<<<<<<<
    '---------------

    'fill this array with your 40-50 Header values
    vFLTRs = Array("AIUH", "ASC", "ABB", "BBS", "YYY", "ZZZ")
    'vFLTRs = Array("*BBS*", "*ABB*", "*ASC*", "*AIUH*")


    With sh
        '-----------------------------------<<<<<<
        LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
        Set rng = Range("C2:C" & LstRw)

        '----Loop Through Array-----
        For i = LBound(vFLTRs) To UBound(vFLTRs)
            For Each cel In rng.Cells
                If cel Like "*" & vFLTRs(i) & "*" Then
                    cel.Offset(, 1) = 1
                End If
            Next cel
        Next i
        With .Cells(1, 1).CurrentRegion
            'filter on all the values in the array
            .AutoFilter Field:=4, Criteria1:=1
            '-----------------------------------<<<<<<<<<

            'walk through the visible rows
            With .Resize(.Rows.Count - 1, 1).Offset(0, 2)
                Set rHDR = .Find(What:=Chr(42), After:=.Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlNext)

                'seed the rows to delete so Union can be used later
                If rHDR.Row > 1 Then Set rDELs = rHDR

                Do While rHDR.Row > 1

                    cnt = 0

                    'increase cnt by both visible and hidden cells
                    Do
                        cnt = cnt + 1
                    Loop While rHDR.Offset(cnt, -1).Value2 > rHDR.Offset(cnt - 1, -1).Value2 And _
                         Intersect(rHDR.Offset(cnt, 0), .SpecialCells(xlCellTypeVisible)) Is Nothing

                    'transfer the values and clear the original(s)
                    With .Cells(rHDR.Row, 1).Resize(cnt, 3).Offset(0, -2)
                        Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
                        Set rDELs = Union(rDELs, .Cells)
                        rHDR.Clear
                    End With

                    'get next visible Header in column C
                    Set rHDR = .FindNext(After:=.Cells(1, 1))
                Loop
                .AutoFilter
            End With

        End With

        'remove the rows
        rDELs.EntireRow.DELETE

    End With

End Sub