Group rows

[Stefan_Sand]

Hello,

is there a way, to group rows through their WBS numbering? What i can do is to create a project structure by indenting the text (thank you, Jeremy Modjeska;
http://j.modjeska.us/?p=31" onclick="window.open(this.href);return false;). - see attached file.

I am now wondering, if there is a possibillity to group the WBS structure, that every subtask is grouped to its main task:

Code: Select all

WBS Number        Task
1                 PROJECT
1.1               ALPHA
1.1.1                  solution intention
1.2               BETA
1.2.1                  nothing to say
1.2.2                  way out
1.2.3                  no way
1.3               GAMMA
1.3.1                  once againn

so, the highest level is the project nr 1
the main tasks are 1.1 - 1.x
and the subtasks start with 1.1.1 or maybe, if a level lower 1.1.1.1 (if i have a more complex structure).

[HansV]

Here is a macro. It creates auxiliary columns to the right of column C.

Code: Select all

Sub GroupWBS()
    Dim m As Long
    Dim n As Long
    Dim r As Long
    Dim r0 As Long
    Dim c As Long
    m = Cells(Rows.Count, 1).End(xlUp).Row
    n = Range(Cells(3, 4), Cells(m, Columns.Count)).Find(What:="*", _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column
    On Error Resume Next
    For c = 4 To n
        Rows.Ungroup
    Next c
    On Error GoTo 0
    Range(Cells(3, 4), Cells(m, n)).ClearContents
    Range(Cells(3, 1), Cells(m, 1)).TextToColumns _
        Destination:=Cells(3, 4), Other:=True, OtherChar:="."
    n = Range(Cells(3, 4), Cells(m, Columns.Count)).Find(What:="*", _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column
    For c = n - 1 To 4 Step -1
        r0 = 0
        For r = 3 To m + 1
            If Cells(r, c) <> Cells(r - 1, c) Then
                If r0 > 0 Then
                    Range(Cells(r0 + 1, 1), Cells(r - 1, 1)).Rows.Group
                End If
                r0 = r
            End If
        Next r
    Next c
End Sub

[Stefan_Sand]

Hi Hans,

i get an error message at:

n = Range(Cells(3, 4), Cells(m, Columns.Count)).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column

[HansV]

Thanks, try this version:

Code: Select all

Sub GroupWBS()
    Dim m As Long
    Dim n As Long
    Dim r As Long
    Dim r0 As Long
    Dim c As Long
    m = Cells(Rows.Count, 1).End(xlUp).Row
    n = Range(Cells(3, 3), Cells(m, Columns.Count)).Find(What:="*", _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column
    If n >= 4 Then
        On Error Resume Next
        For c = 4 To n
            Rows.Ungroup
        Next c
        On Error GoTo 0
        Range(Cells(3, 4), Cells(m, n)).ClearContents
    End If
    Range(Cells(3, 1), Cells(m, 1)).TextToColumns _
        Destination:=Cells(3, 4), Other:=True, OtherChar:="."
    n = Range(Cells(3, 4), Cells(m, Columns.Count)).Find(What:="*", _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column
    For c = n - 1 To 4 Step -1
        r0 = 0
        For r = 3 To m + 1
            If Cells(r, c) <> Cells(r - 1, c) Then
                If r0 > 0 Then
                    Range(Cells(r0 + 1, 1), Cells(r - 1, 1)).Rows.Group
                End If
                r0 = r
            End If
        Next r
    Next c
End Sub

Remark: if you have grouped one or more rows, you will have to remove the grouping manually before you run the macro for the first time. After that, the macro should take care of everything.

[Stefan_Sand]

thank you, Hans, that is pretty cool!