VBA - Group with subgroup extract using keyword - excel

Question

Have data on columnA and trying to filter data using keywords. member of groups is in the down adjacent cells. starting with +.
Sub Mymacro()
Range("B2:B2000").Clear
For Each Cell In Sheets(1).Range("A1:A2000")
matchrow = Cell.Row
Find = "*" + Worksheets("Sheet1").Range("B1") + "*"
If Cell.Value Like Find Then
Cell.Offset(0, 1).Value = Cell.Offset(0, 0).Value
End If
Next
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$1" Then
Call Mymacro
End If
End Sub
The above code is extracting text correctly with the green text but the expecting item is still missing which is just highlighted using the red text. tried a couple of options but no luck.

Answer 1

Referencing a worksheet with its index number as Sheets(1) is not advisable. It refers to the first sheet in the workbook including a chart sheet. If the sheet referred is moved from its first position in the workbook then the macro will run in the new worksheet at the first position. If the first sheet is a chart sheet, the macro will cause error. Hence, please replace below Sheets(1) reference with Sheet name like Sheets("Sheet1") or VBA Project worksheet name as Sheet1
Option Explicit
Sub Mymacro()
Dim fltArea As Range, fltAreas As Range, fltAreasGroup As Range
Dim lastRow As Long
lastRow = Sheets(1).Range("A1048576").End(xlUp).Row
Sheets(1).Range("B2:B" & lastRow).Clear
Sheets(1).Range("$A$1:$A$" & lastRow).AutoFilter Field:=1, Criteria1:="=+*", _
Operator:=xlAnd
Set fltAreasGroup = Sheets(1).Range("$A$2:$A$" & lastRow).SpecialCells(xlCellTypeVisible)
Sheets(1).AutoFilterMode = False
For Each fltAreas In fltAreasGroup.Areas
Set fltArea = fltAreas.Offset(-1).Resize(fltAreas.Rows.Count + 1, 1)
If InStr(1, Join(Application.Transpose(Application.Index(fltArea.Value, 0, 1)), ","), _
Sheets(1).Range("B1").Value, vbTextCompare) > 0 Then
fltArea.Offset(, 1).Value = fltArea.Value
End If
Next
Sheets(1).Range("$A$1:$B$" & lastRow).AutoFilter Field:=1, Criteria1:="=*" & Sheets(1).Range("B1").Value & "*", _
Operator:=xlAnd
Sheets(1).Range("$A$1:$B$" & lastRow).AutoFilter Field:=2, Criteria1:="="
Set fltAreas = Sheets(1).Range("$A$2:$A$" & lastRow).SpecialCells(xlCellTypeVisible)
Sheets(1).AutoFilterMode = False
For Each fltArea In fltAreas
fltArea.Offset(, 1).Value = fltArea.Value
Next
End Sub