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

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