Grouping rows between data headers via VBA

[jmm765psu]

Hello, long time lurker, first time poster. I have an SAP output that is organized into levels in column A. Level 00 is the project level additional levels/sublevels (01, 02, 03, etc) make up the work breakdown for the project. Then, there are multiple projects in the same sheet. An example would look something like this:

[TABLE="class: grid, width: 400"]
<tbody>[TR]
[TD]Level (A1)[/TD]
[TD]Project Info (B1)[/TD]
[/TR]
[TR]
[TD]00[/TD]
[TD]Project 1[/TD]
[/TR]
[TR]
[TD]01[/TD]
[TD]Subtask[/TD]
[/TR]
[TR]
[TD]02[/TD]
[TD]Subsubtask[/TD]
[/TR]
[TR]
[TD]02[/TD]
[TD]Subsubtask[/TD]
[/TR]
[TR]
[TD]03[/TD]
[TD]Subsubsubtask[/TD]
[/TR]
[TR]
[TD]02[/TD]
[TD]Subsubtask[/TD]
[/TR]
[TR]
[TD]01[/TD]
[TD]Subtask[/TD]
[/TR]
[TR]
[TD]02[/TD]
[TD]Subsubtask[/TD]
[/TR]
[TR]
[TD]00[/TD]
[TD]Project 2[/TD]
[/TR]
[TR]
[TD]01[/TD]
[TD]Subtask[/TD]
[/TR]
[TR]
[TD]01[/TD]
[TD]Subtask[/TD]
[/TR]
[TR]
[TD]02[/TD]
[TD]Subsubtask[/TD]
[/TR]
[TR]
[TD]03[/TD]
[TD]Subsubsubtask[/TD]
[/TR]
[TR]
[TD]03[/TD]
[TD]Subsubsubtask[/TD]
[/TR]
[TR]
[TD]04[/TD]
[TD]Subsubsubsubtask[/TD]
[/TR]
[TR]
[TD]01[/TD]
[TD]Subtask[/TD]
[/TR]
[TR]
[TD]00[/TD]
[TD]Project 3[/TD]
[/TR]
[TR]
[TD]01[/TD]
[TD]Subtask[/TD]
[/TR]
[TR]
[TD]01[/TD]
[TD]Subtask[/TD]
[/TR]
</tbody>[/TABLE]

I've been searching for a way to group cells (via Group, not hide) to group all of the subtasks in between the 00 level for each project while keeping the 00 level in view. I want to use the group function and not the autofilter function because my group desires the collapsible functionality of grouping. The file will always have varying lengths and the projects varying number of subtasks. There are no spaces between the projects. The final desired output of the above would look something like this:

[TABLE="class: grid, width: 400"]
<tbody>[TR]
[TD][/TD]
[TD]Level (A1)[/TD]
[TD]Project Info (B1)[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]00[/TD]
[TD]Project 1[/TD]
[/TR]
[TR]
[TD]+[/TD]
[TD]00[/TD]
[TD]Project 2[/TD]
[/TR]
[TR]
[TD]+[/TD]
[TD]00[/TD]
[TD]Project 3[/TD]
[/TR]
[TR]
[TD]+[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

I've found a few threads showing slightly different iterations but I haven't been able to tweak them to work for my specific criteria. Can anyone help me out?

I am on a PC running Office 2010

 

[Takae]

Please try it

Sub jmm()
Dim LR As Long, i As Long, j As Long
Dim arr()
LR = cells(Rows.count, 1).End(xlUp).Row
Range(Rows(2), Rows(LR)).ClearOutline
For i = 2 To LR
    If cells(i, 1).Value = "00" Then
        ReDim Preserve arr(j)
            arr(j) = i
            j = j + 1
    End If
Next
For i = 0 To UBound(arr) - 1
    Range(Rows(arr(i) + 1), Rows(arr(i + 1) - 2)).Rows.Group
Next
End Sub

 

[jmm765psu]

Takae, thank you so much! The only change I made was from "Rows(arr(i + 1) - 2" to "Rows(arr(i + 1) - 1" because the grouping wasn't picking up the final row before the next "00"

There is one other small tweak I am trying to figure out. The final project in the list does not have column A ending in "00" so currently I would have to manually add that before running the macro or manually group the final project. Each of these is a small effort but it would be nice if the last project just grouped like the rest. Column A could end in "01", "02", "03", etc so I'm trying to work it based on the last cell being blank or by using the macro to find the first blank cell and adding a "00". Any thoughts?

 

[tonyyy]

jmm765psu,

For i = 0 To UBound(arr) - 1

The "-1" in the above line drops the final array index, thus leaving the final project out of the .Group routine. Deleting the "-1" though will generate an error, as the "Rows(arr(i) + 1)" will result in a "Subscript out of range". One option is to introduce error handling, or, as below, simply add a line to capture the final group:

Sub jmm()
Dim LR As Long, i As Long, j As Long
Dim arr()
LR = Cells(Rows.Count, 1).End(xlUp).Row
Range(Rows(2), Rows(LR)).ClearOutline
For i = 2 To LR
    If Cells(i, 1).Value = 0 Then
        ReDim Preserve arr(j)
            arr(j) = i
            j = j + 1
    End If
Next
For i = 0 To UBound(arr) - 1
    Range(Rows(arr(i) + 1), Rows(arr(i + 1) [COLOR=#ff0000]- 1[/COLOR])).Rows.Group
Next
[COLOR=#ff0000]Range(Rows(arr(UBound(arr)) + 1), Rows(LR)).Rows.Group[/COLOR]
End Sub

Kudos to Takae for the heavy lifting.

Cheers,

tonyyy

 

[jmm765psu]

That did the trick! Superbly done both of you. Thanks!

 

[tonyyy]

You're very welcome...