• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro/VBA for grouping/outline of WBS structure

Status
Not open for further replies.
momcaro

momcaro

Member
I have searched high and low for this and I'm wondering if it's even possible now... but if I'm to find the answer, I believe this is the place!

In exporting or copying/pasting a project plan from Project into Excel, I would like to add grouping of rows just as found in Project, where I can expand and collapse tasks and their subtasks.
I have the WBS numbering, even the indentation, I'm only missing the grouping.
Manual is not an option as there are thousands of tasks and I would like to export multiple times.
The goal is to share the plan with people who don't have Project installed on their machines.
Thank you!
 
It could be done...with conditions. XL (2010) only supports 8 levels of indentation. Is this deep enough for your project?
If yes, can you post an example of the data, and we can take a crack at writing the macro?
 
I think 8 is probably deep enough. I only exported the higher level tasks, which should be good enough for now. Let me know if the macro would need to be expanded for more levels.
Thank you!
 

Attachments

  • Book1.xlsx
    10.4 KB · Views: 174
Try giving this a shot.
Code: 
Sub BuildOutline()
Dim lastRow As Long
Dim grpRow(1 To 8) As Long
Dim i As Long
Dim changeRow As Long

Application.ScreenUpdating = False
With ActiveSheet
    .Cells.EntireRow.ClearOutline
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    'Setup initial values
    For i = 1 To 8
        grpRow(i) = lastRow
    Next i
   
   
    changeRow = lastRow
    For i = lastRow - 1 To 2 Step -1
        If lvlCount(.Cells(i, 1).Value) < lvlCount(.Cells(changeRow, 1).Value) Then
            .Range(i + 1 & ":" & grpRow(lvlCount(.Cells(i, 1).Value))).EntireRow.Group
            grpRow(lvlCount(.Cells(i, 1).Value)) = i - 1
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

Function lvlCount(WBS As String) As Integer
lvlCount = Len(WBS) - Len(Replace(WBS, ".", "")) + 1
End Function
 
Ah. Okay, tried to do a bit more testing. This seems to be an improvement, at least.
Code: 
Sub BuildOutline()
Dim lastRow As Long
Dim grpRow(1 To 8) As Long
Dim i As Long, j As Long
Dim curLVL As Long

Application.ScreenUpdating = False
With ActiveSheet
    .Cells.EntireRow.ClearOutline
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    'Setup initial values
   For i = 1 To 8
        grpRow(i) = lastRow
    Next i

    For i = lastRow - 1 To 2 Step -1
        curLVL = lvlCount(.Cells(i, 1).Value)
        If curLVL > lvlCount(.Cells(i + 1, 1).Value) Then
            grpRow(curLVL) = i
        ElseIf curLVL < lvlCount(.Cells(i + 1, 1).Value) Then
            .Range(i + 1 & ":" & grpRow(curLVL + 1)).EntireRow.Group
            'If we go up a level, all previous lower levels reset
            For j = curLVL + 1 To 8
                grpRow(j) = i - 1
            Next j
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

Function lvlCount(WBS As String) As Integer
lvlCount = Len(WBS) - Len(Replace(WBS, ".", "")) + 1
End Function
 
I'm impressed, truly :) But it's still missing a little something: at the bottom (2's and 3's), the indentation shows up (little dots to the right of the expand/collapse lines), but no expand/collapse lines. For example, I cannot collapse the 3.3's, only the 3's.
I know you're very warm!!
 

Attachments

  • Book1.xlsm
    17.9 KB · Views: 124
Ah, I see now. Goofy little thing about XL...originally accountant type people designed it, and their totals are at the bottom, so the outline rolls down. In Data ribbon, in bottom of Outline group, you can hit the little button, and remove that checkmark:
upload_2015-1-22_10-35-23.png

However, since we may use this on other workbooks, I added a line into the code to have the macro make this switch. :cool:
 

Attachments

  • Better Outliner.xlsm
    19.3 KB · Views: 607
Beautiful!!! I cannot thank you enough, there is no way I could have come up with any of that and this has been driving me crazy... so THANK YOU!!
 
Glad I could help. I think I'll hang on to this little macro, I can see some uses for it in my own workplace. :DD
 
just fwiw, last time I got myself into something like this, it ended up swelling out of control.

Excel kinda sucks for project management - which I guess I should have seen coming - but ya know....
 
Thanks for this as well! Was working on a macro of my own, thought to group by WBS, searched and found you'd already done it already - and beautifully written. _Really_ helpful.
 
Luke M,
Thanks for this tool, I would really be able to use it, but...
I noticed there's still a little obnoxious critter hiding somewhere.
I have included a file to illustrate (it was derived from the parts list of a -real!- train set, so I had to clip it somewhat; it was originally 148,289 lines long and 69MB big!...): As you can see when you "fold-up" to level 3, you'll notice 1.1.7 is missing! When you then unfold 1.1.6, then 1.1.6.2, you'll see 1.1.7 "remained" right after 1.1.6.2.3!...
I'm a perfect "noob" in VBA, though, so I must apologize for not "killing" the bug myself, I'm afraid...
Thanks again,
Marc
 

Attachments

  • test.xlsm
    351.6 KB · Views: 99
please take my tool here to do so, i built a WBS structure and the ability to group or ungroup the WBS structure.
 

Attachments

  • TestORGStruktFinalwithPicture.xlsm
    247.4 KB · Views: 241
Sandy_X, your code does not work on 64-bit Excel. Need to use PtrSafe Function declares. Once I did that it works great. You may want to post an updated version.
 
Hi, i am using Office 2016 32 bit... you still can use: WBSNumbering, IndentBasedOnWBSLevel and UngroupWBS
you want to use the ORG maker, right? -> maybe you should change the use of the 32 bit library, but i do not know, how to do so or to test ... sorry.
 
ok, what i found was, you only have to change into:
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
- if anyone of you is using the 64 bit Office version. Please note that, to use the Stoplight WBS Tree, the pictures you use should be in the same directory nas the workbook is, because in any other directory it will not update.
 
Sandy_X Toatally awesome thing you made!
Is this button Get WBS suppose to get the list from WBS Maker sheet?
That dont work for me, I really want that to work, would be superb way to show project status. Again, very impressed!
 
Hi,
yes thats for the solution i am looking for to copy the wbs Numbers from the WBS Maker sheet.
Meanwhile i have this:
Code: 
Sub CopyData()
    Dim wshS As Worksheet
    Dim rngLastSCell As Range
    Dim lngLastSRow As Long
    Dim wshT As Worksheet
    Dim lngLastTRow As Long
    Application.ScreenUpdating = False
    Set wshS = Worksheets("WBS Maker")
    Set rngLastSCell = wshS.Cells.Find(What:="END OF PROJECT")
    lngLastSRow = rngLastSCell.End(xlUp).Row
    Set wshT = Worksheets("WBS ORG")
    lngLastTRow = wshT.Range("G" & wshT.Rows.Count).End(xlUp).Row
    wshT.Range("G2:G" & lngLastTRow & ",I2:I" & lngLastTRow).ClearContents
    wshS.Range("A3:A" & lngLastSRow).Copy Destination:=wshT.Range("G2")
    wshS.Range("B3:B" & lngLastSRow).Copy Destination:=wshT.Range("I2")
    If lngLastTRow > lngLastSRow - 1 Then
        wshT.Range("A" & lngLastSRow - 1).Resize(lngLastTRow - lngLastSRow + 1, 3).Clear
        wshT.Range("J" & lngLastSRow).Resize(lngLastTRow - lngLastSRow + 1, 1).Clear
    ElseIf lngLastTRow < lngLastSRow - 1 Then
        wshT.Range("A" & lngLastTRow - 1).Resize(1, 3).AutoFill _
            Destination:=wshT.Range("A" & lngLastTRow - 1).Resize(lngLastSRow - lngLastTRow, 3)
        wshT.Range("J" & lngLastTRow).AutoFill _
            Destination:=wshT.Range("J" & lngLastTRow).Resize(lngLastSRow - lngLastTRow, 1)
    End If
    Application.ScreenUpdating = True
End Sub
but it copies the formats as well...
 
Last edited by a moderator:
to show teh project status you have to adopt the make org structure code - add for the root and child nodes a 2; the problem is, that i used the normal code in both procedures thats why the picture stats do not change.
 
would you please change the code for 64bit . i couldnt run it.please help
Sandy_X said:
ok, what i found was, you only have to change into:
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
- if anyone of you is using the 64 bit Office version. Please note that, to use the Stoplight WBS Tree, the pictures you use should be in the same directory nas the workbook is, because in any other directory it will not update.
Click to expand...
 
Status
Not open for further replies.
Back
Top