VBA to group by text

[glynn1969]

Hello, I'm looking for vba that can automatically apply grouping to a data set (that is current just a list with no grouping at all) as shown in first image- my issue is that my actual data set is hundreds of lines long and doing manually is very time consuming.

I have tried the following code but it ends up just grouping everything by BUD a per screenshot 2


Sub GroupByMag2()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim groupStart As Long

' Set the worksheet to work with
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your actual sheet name

' Find the last row with data in column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

groupStart = 0 ' Initialize the group start

' Loop through each row in column A
For i = 1 To lastRow + 1
' Check if the cell contains "mag"
If i <= lastRow And InStr(1, ws.Cells(i, "A").Value, "mag", vbTextCompare) > 0 Then
If groupStart > 0 Then
' End the previous group before starting the new one
ws.Rows(groupStart & ":" & i - 1).Group
End If
' Start a new group from the current "mag" row
groupStart = i
ElseIf i > lastRow And groupStart > 0 Then
' At the end of data, group the last set of rows
ws.Rows(groupStart & ":" & lastRow).Group
End If
Next i

' Optionally, expand all groups to level 1
ws.Outline.ShowLevels RowLevels:=1
End Sub

 

[NdNoviceHlp]

Trial changing this line...

groupStart = 0 ' Initialize the group start
groupStart = 1 ' Initialize the group start

HTH. Dave
ps. please use code tags

 

[glynn1969]

Hello, thank you for your reply. Do you mean to add these two lines in or change the line from
groupStart = 0 ' Initialize the group start TO
groupStart = 1 ' Initialize the group start.

I'm in UK and going to bed but will try code in work tomorrow.

Can I ask what you mean by code tags please

 

[NdNoviceHlp]

Apologies for not being very clear. I messed around with it and it's not as easy as it seemed. I'll assist later today if you haven't resolved this yet. To post code, copy and paste it to the forum, select the code and then select the VBA cloud icon (at the top of the reply window) to apply code tags for easier readability. Dave

 

[glynn1969]

Apologies for not being very clear. I messed around with it and it's not as easy as it seemed. I'll assist later today if you haven't resolved this yet. To post code, copy and paste it to the forum, select the code and then select the VBA cloud icon (at the top of the reply window) to apply code tags

Sub GroupByMag2()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim groupStart As Long

' Set the worksheet to work with
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your actual sheet name

' Find the last row with data in column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

groupStart = 0 ' Initialize the group start

' Loop through each row in column A
For i = 1 To lastRow + 1
' Check if the cell contains "mag"
If i <= lastRow And InStr(1, ws.Cells(i, "A").Value, "mag", vbTextCompare) > 0 Then
If groupStart > 0 Then
' End the previous group before starting the new one
ws.Rows(groupStart & ":" & i - 1).Group
End If
' Start a new group from the current "mag" row
groupStart = i
ElseIf i > lastRow And groupStart > 0 Then
' At the end of data, group the last set of rows
ws.Rows(groupStart & ":" & lastRow).Group
End If
Next i

' Optionally, expand all groups to level 1
ws.Outline.ShowLevels RowLevels:=1
End Sub

 

[glynn1969]

Sub GroupByMag2()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim groupStart As Long

' Set the worksheet to work with
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your actual sheet name

' Find the last row with data in column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

groupStart = 0 ' Initialize the group start

' Loop through each row in column A
For i = 1 To lastRow + 1
' Check if the cell contains "mag"
If i <= lastRow And InStr(1, ws.Cells(i, "A").Value, "mag", vbTextCompare) > 0 Then
If groupStart > 0 Then
' End the previous group before starting the new one
ws.Rows(groupStart & ":" & i - 1).Group
End If
' Start a new group from the current "mag" row
groupStart = i
ElseIf i > lastRow And groupStart > 0 Then
' At the end of data, group the last set of rows
ws.Rows(groupStart & ":" & lastRow).Group
End If
Next i

' Optionally, expand all groups to level 1
ws.Outline.ShowLevels RowLevels:=1
End Sub

 

[glynn1969]

Apologies for not being very clear. I messed around with it and it's not as easy as it seemed. I'll assist later today if you haven't resolved this yet. To post code, copy and paste it to the forum, select the code and then select the VBA cloud icon (at the top of the reply window) to apply code tags for easier readability. Dave

Thanks for coming back to me, I've not found a solution yet. I guess it must be difficult as nobody else has even tried. Thank you

 

[NdNoviceHlp]

It took some messing around to make this more useable. The function will either group or ungroup a range based on the inputted search string. Here's the function..

Function GroupThem(Rng As Range, SearchStr As String, ActStr As String)
'Rng is search range
'SearchStr is partial search word
'ActStr = "G" for group OR not G (ie. "U") for ungroup
Dim ws As Worksheet, First As Boolean, FirstCell As Integer, LastCell As Integer, i As Integer
'Thanks to Andrew Poulsom for his part here....
'https://www.mrexcel.com/board/threads/vba-grouping-rows-based-on-criteria.313605/
'get sheet name
Set ws = Rng.Parent
First = True
'loop Rng
For i = Rng.Cells(1, 1).Row To Rng.Count
'if Rng item contains search string
If i <= Rng.Count And InStr(1, Rng.Cells(i, 1).Value, SearchStr, vbTextCompare) > 0 Then
    If First = False Then
    First = True
        If ActStr = "G" Then
        ws.Rows(FirstCell & ":" & LastCell).Group
        Else
        ws.Rows(FirstCell & ":" & LastCell).Ungroup
        End If
    End If
Else
    If First = True Then
    FirstCell = i
    LastCell = i
    First = False
    Else
    LastCell = i
    End If
End If
Next i
End Function

To operate, set your range and call the function...

Dim Rng As Range, ws As Worksheet, LastRow As Integer
'Change "Sheet1" to your actual sheet name
Set ws = ThisWorkbook.Sheets("Sheet1")
' Find the last row with data in column A
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set Rng = ws.Range("A1:A" & LastRow)

'Function GroupThem(Search Range, Search String, "G" for group OR anything else for ungroup ie. "U"
'to group
Call GroupThem(Rng, "bud", "G")
Call GroupThem(Rng, "mopex", "G")
Call GroupThem(Rng, "mag", "G")

'to ungroup
'Call GroupThem(Rng, "bud", "U")
'Call GroupThem(Rng, "mopex", "U")
'Call GroupThem(Rng, "mag", "U")

Thanks to Andrew Poulsom for the original code that was adapted. HTH. Dave

 

[Peter_SSs]

@glynn1969
Re code tags: You need to paste your code between the tags, see image below. My signature block at the bottom of this post has more details as well.