CODEWITHSUNDEEP
excelregexvba
user1582596
user1582596

Reputation: 503

VBA - Group with subgroup extract using keyword

Have data on columnA and trying to filter data using keywords. member of groups is in the down adjacent cells. starting with +.

enter image description here

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.

Upvotes: 1

Views: 288

Answers (1)

Naresh
Naresh

Reputation: 3034

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

enter image description here enter image description here

Upvotes: 1

Related Questions