VBA - Group with subgroup extract using keyword

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.

Naresh · Accepted Answer · 2021-07-07 17:39:46Z

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

edited Jul 7, 2021 at 17:39

answered Jul 7, 2021 at 16:55

Naresh

3,0372 gold badges11 silver badges16 bronze badges

Sign up to request clarification or add additional context in comments.

7 Comments

user1582596 Over a year ago

wow That's gr8. Thank you @Naresh . didn't think about Autofiler. i was trying with string + regex group to display. just wondering if Criteria1:="=+*" can be replaced with Criteria1:="=\s*" or Criteria1:="={space}*" or Criteria1:="=?{space}*" , Criteria1:="=\t " or Criteria1:="={tab}" if needed.

Naresh Over a year ago

I think it will accpept only literal text in the between = and . So, Criteria1:="= *" .. (space*) should work.. Evaluating each cell with regexp will make it slow.. Also grouping will be difficult I guess.

Naresh Over a year ago

For Criteria1:="={tab}*", try equivalent number of spaces like Criteria1:="= *".

Naresh Over a year ago

Yes.. I checked it now and noticed we can not filter a column for cells starting with space. In cell "C2" (or any other column), enter this formula =LEFT(A2,1)=" " and copy it down till last cell of column A. You will get "TRUE" for all the cells in Col A beginning with a space. Then instead of colA you can apply the FIRST filter in the macro to col C as Sheets(1).Range("$C$1:$C$" & lastRow).AutoFilter Field:=1, Criteria1:="TRUE" Also, add this line at the beggining of the macro Sheets(1).AutoFilterMode = False before any autofilter statement. .. everything else will be the same.

Naresh Over a year ago

@user1582596 Glad to help .. excited to learn :) thanks

|

Collectives™ on Stack Overflow

VBA - Group with subgroup extract using keyword

1 Answer 1

7 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

7 Comments

Your Answer

Sign up or log in

Post as a guest

Related