How do you automatically create a Excel macro for a work breakdown structure? This is not that difficult and will bring you undreamt-of time savings.
Four years ago I read the book by Paul A. Akers 2 Second Lean for the first time. Paul is all about continuous improvement. The book is about his lean journey: once for him personally and once with his company. You can watch numerous videos on Youtube. I still read it in English at the time – but found it so entertaining that I read it in one go in two days.
Paul Aker writes:
I said to my people, “Just give me a single 2 second improvement a day. That’s it. That’s all I ask for. A 2 second improvement.”Paul Aker
I was pretty impressed at the time. An improvement every day that only saves 2 seconds. It may sound like very little at first, but it has a huge impact. Since then I have been improving my work processes in small steps.
And this 2-Second-Lean is about the automatic creation of a work breakdown structure.
You can see the function in the two articles:
What is happening?
Before we start, let’s take a look at the slow motion variant of the macro.
- Delete current work breakdown structure
- Get start setup
- Build the work breakdown structure line by line and calculate positions and insert shapes
- Center the top shape
First, delete everything
First, an existing WBS is deleted. The plan is built entirely using shape elements: rectangles and connecting lines. All elements get a label with the name. They start with N_. Therefore it is possible to find and delete them simply by name.
Sub DeleteWorkBreakdownStructure() Dim i As Integer Dim shape1 For Each shape1 In ActiveSheet.Shapes If Left$(shape1.name, 2) = "N_" Then shape1.Delete End If Next End Sub
The automatic structure of the work breakdown structure is carried out via the CreateWorkBreakdownStructure sub.
First, we get the settings that are stored in the Setup sheet. The corresponding cells have been given a name. This allows us to always find the values, even if the cell position changes.
Access to a value is via the Range object. The respective sheet is always the basis. With us is the Setup.
spaceYLevel0 = Sheets("Setup").Range("LEVEL0_SPACE_Y") spaceXLevel1 = Sheets("Setup").Range("LEVEL1_SPACE_X") spaceYLevel3 = Sheets("Setup").Range("LEVEL3_SPACE_Y") spaceXLevel3 = Sheets("Setup").Range("LEVEL3_SPACE_X")
Then we initialize a few variables with their start values and start with the main loop.
Crack the WBS-code
Now it’s about codes, the WBS code.
We are now going to get this code over the main loop. All entries from the Start sheet are run through in this. The controlling value is in the Code column. We read this into a variable wbsCode via the object Cells(row, column).
Do wbsCode = Sheets("Start").Cells(row, COL_CODE) wbsCodeParent = GetParentWBS(wbsCode) pParent = GetLastPosition(wbsCodeParent)
So that we know at which hierarchy level and position the new element should be arranged, we also need the parent element. We determine this with our own function GetParentWBS(wbsCode) and pass our WBS code as a parameter.
The WBS code is structured using points. To find the parent element, we have to go through the WBS code from the right until we find a point. Then we can return the substring from the left to this position-1 as a result.
Function GetParentWBS(wbsCode As String) As String Dim i As Integer Dim result As String result = "" For i = Len(wbsCode) To 1 Step -1 If Mid$(wbsCode, i, 1) = "." Then result = Left$(wbsCode, i - 1) Exit For End If Next GetParentWBS = result End Function
The last position
Once we have found the parent element, we get the current position data. We also do this with our own function. I called it GetLastPosition.
Function GetLastPosition(wbsCode As String) As Position Dim row As Integer Dim result As Position Dim found As Boolean Dim w As String found = False row = ROW_START Do w = Sheets("Start").Cells(row, COL_CODE) If wbsCode = w Then found = True result.x = Sheets("Start").Cells(row, COL_X) result.y = Sheets("Start").Cells(row, COL_Y) result.count = Sheets("Start").Cells(row, COL_COUNT) End If row = row + 1 Loop Until w = "" Or found = True GetLastPosition = result End Function
The function, like the main loop, runs through all elements in the Start sheet. It looks in the calculated columns X, Y and Count. How these are calculated will be explained later.
The three values are returned as a result. There is a separate data type for this.
Type Position x As Double y As Double count As Integer End Type
With this position information (stored in the variable pParent) of the parent element, we then come back into the main loop.
Now there is structure
Our work breakdown structure is now getting its structure. The first 3 levels can be freely formatted in the Setup sheet. We now have to recognize these levels in the source code and position them according to the parameters that we read when the program started.
To recognize the level, we simply count the points in the WBS code. This is what the CountPoints function does. 0 points corresponds to the top level, 1 point to the second. The formatting of level 3 applies to all others.
In the if-queries of the level, we get further specific parameters of the level, such as element width or element height. And of course the output text.
Our work breakdown structure consists of rectangle shapes. We access these in VBA with the Shapes(Name) object. The shape was previously given the name manually in the Setup sheet.
So that we can position a new shape correctly, we save the current position using the variable p. It is also of the position type.
level = CountPoints(wbsCode) If level = 0 Then 'usualy projectname caption = Sheets("setup").Shapes("LEVEL_1").TextFrame.Characters.Text w = Sheets("Setup").Shapes("LEVEL_1").Width h = Sheets("Setup").Shapes("LEVEL_1").Height p.y = h ElseIf level = 1 Then 'phase or part project caption = Sheets("setup").Shapes("LEVEL_2").TextFrame.Characters.Text w = Sheets("Setup").Shapes("LEVEL_2").Width h = Sheets("Setup").Shapes("LEVEL_2").Height If pParent.count = 0 Then p.x = 0 p.y = p.y + h * spaceYLevel0 Else d = GetLastMaxPosition(wbsLevel1Old) If d <> 0 Then p.x = d + spaceXLevel1 * w Else p.x = pParent.x + spaceXLevel1 * w End If p.y = pParent.y End If Else caption = Sheets("setup").Shapes("LEVEL_3").TextFrame.Characters.Text w = Sheets("Setup").Shapes("LEVEL_3").Width h = Sheets("Setup").Shapes("LEVEL_3").Height If pParent.count = 0 Then p.x = pParent.x + w * spaceXLevel3 If level = 2 Then d = Sheets("Setup").Shapes("LEVEL_2").Height Else d = h End If p.y = pParent.y + d * spaceYLevel3 Else p.x = pParent.x p.y = pParent.y + h * spaceYLevel3 End If End If
With the lines above we calculated the position for the current element for every possible level. We saved the planned height and width in the variables h and w. And the title is stored in the variable caption.
With the following lines, we save the calculated position for the respective element in sheet Start. They are stored there as columns X, Y and Count.
Everything is saved
We do this in three ways. The structure of the work breakdown structure can be very large and contain many levels. But if we build a new branch on the second level, we need the max. position of the parent element. That is why we save the current X position for all elements on the parent level, so to speak as the maximum value.
p.count = pParent.count + 1 Call SetPositions(wbsCodeParent, p) Call SetPosition(wbsCodeParent, p) p.count = 0 Call SetPosition(wbsCode, p)
And save again
So what happens in the SetPositions procedure? All elements of the Start sheet are run through again. But first, we get the WBS code of the second level, e.g. 1.2 from 220.127.116.11.1.
Because that’s our branch. Below this, all elements are arranged one below the other, like the elements in Windows Explorer. When running through, we set the Y coordinate to the new value for all elements at the same level.
Sub SetPosition(wbsCode As String, p As Position) Dim row As Integer Dim result As Position Dim found As Boolean Dim w As String found = False row = ROW_START Do w = Sheets("Start").Cells(row, COL_CODE) If wbsCode = w Then found = True Sheets("Start").Cells(row, COL_X) = p.x Sheets("Start").Cells(row, COL_Y) = p.y Sheets("Start").Cells(row, COL_COUNT) = p.count End If row = row + 1 Loop Until w = "" Or found = True End Sub
Now the labeling comes
Back in the main loop, the positions are now saved and can be read as a new position the next time through.
We take care of the labeling of our WBS in the next step. The text is also stored as a variable in the variable caption. We are now replacing these variables with the data from the Start sheet.
First, we check if the user wants the progress formatting. If yes, we get the appropriate format for the respective level in the variable caption. If no, caption remains as it was.
If UCase(Sheets("Setup").Range("PROGRESS_COLORS")) = "J" Then If progress = 0 Then caption = Replace(caption, "$PROGRESS", Sheets("Setup").Range("FORMAT_NOT_STARTED")) ElseIf progress = 1 Then caption = Replace(caption, "$PROGRESS", Sheets("Setup").Range("FORMAT_COMPLETED")) Else caption = Replace(caption, "$PROGRESS", Sheets("Setup").Range("FORMAT_IN_PROGRESS")) End If End If
In the next step, we replace the internal variables with the data from the Start sheet. You can do this using the VBA function Replace.
caption = Replace(caption, "$CODE", Sheets("Start").Cells(row, COL_CODE)) caption = Replace(caption, "$NAME", Sheets("Start").Cells(row, COL_NAME)) caption = Replace(caption, "$PROGRESS", Format(progress, "0%")) For i = 10 To 1 Step -1 caption = Replace(caption, "$F" & CStr(i), Sheets("Start").Cells(row, COL_FIELDS + i - 1)) Next
Shapes and connectors
Then the exciting part finally comes. We create a rectangle and insert it.
Call InsertRectangle(wbsCode, caption, p.x, p.y, w, h, level, progress) If level > 0 Then Call InsertConnector(wbsCodeParent, wbsCode, level)
We also do this via our own Procedure InsertRectangle. The insertion should take place on the current sheet, therefore we use ActiveSheet.
A new shape is inserted using the Shapes.AddShape method. But you don’t necessarily have to take a rectangular shape.
At https://docs.microsoft.com/de-de/office/vba/api/office.msoautoshapetype you will find the names of the other options.
Sub InsertRectangle(name As String, caption As String, x As Double, y As Double, w As Double, h As Double, level As Integer, progress As Double) Dim s As String Dim c As Long Dim id As String ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, x, y, w, h).Select id = "N_" & name Selection.name = id If level > 1 Then s = "3" Else s = CStr(level + 1) End If
We use the WBS code again as the name. We put the text “N_” in front of it.
To get the formatting from the spreadsheet Setup, we use the Excel function format transfer. This is done with the command Sheets(Name).Shapes (Name).PickUp and the transfer with Apply.
Sheets("Setup").Shapes("LEVEL_" & s).PickUp ActiveSheet.Shapes(id).Apply If UCase(Sheets("Setup").Range("PROGRESS_COLORS")) = "J" Then If progress = 0 Then Selection.ShapeRange.Fill.ForeColor.RGB = Sheets("Setup").Range("PROGRESS_NOT_STARTED").Cells.Interior.Color ElseIf progress = 1 Then Selection.ShapeRange.Fill.ForeColor.RGB = Sheets("Setup").Range("PROGRESS_COMPLETED").Cells.Interior.Color Else Selection.ShapeRange.Fill.ForeColor.RGB = Sheets("Setup").Range("PROGRESS_IN_PROGRESS").Cells.Interior.Color End If End If Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = caption End Sub
Then the source code decides whether to format after progress. If yes, the color settings are read accordingly and transferred to the Shape.Interior.Color.
At the end the title of the shape is adjusted.
The connection lines are inserted in the same way. We use the names of the rectangle elements as contact points. And we know that from the WBS code.
Sub InsertConnector(wbsCodeFrom As String, wbsCodeTo As String, level As Integer) Dim pFrom As Integer Dim pTo As Integer If level = 1 Then pFrom = 3 pTo = 1 Else pFrom = 3 pTo = 2 End If ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 0, 0, 100, 100).Select Selection.name = "N_" & wbsCodeFrom & "_" & wbsCodeTo Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes("N_" & wbsCodeFrom), pFrom Selection.ShapeRange.ConnectorFormat.EndConnect ActiveSheet.Shapes("N_" & wbsCodeTo), pTo Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadStealth With Selection.ShapeRange.Line .EndArrowheadLength = msoArrowheadLong .EndArrowheadWidth = msoArrowheadWide .Visible = msoTrue .Weight = 1 .Transparency = 0 End With Sheets("Setup").Shapes("CONNECTOR").PickUp ActiveSheet.Shapes("N_" & wbsCodeFrom & "_" & wbsCodeTo).Apply End Sub
At the end of the main loop, we still check whether the inserted element was the first and remember the WBS code. An the end we need that to center the element.
Then we prepare everything for the next run: count up row, note level and WBS code – ready for the next element!
If row = ROW_START Then firstshape = "N_" & wbsCode row = row + 1 levelOld = level wbsOld = wbsCode If level = 1 Then wbsLevel1Old = wbsCode wbsCode = Sheets("Start").Cells(row, COL_CODE) Loop Until wbsCode = ""
Finally, the first element is centered. Since we have saved all X values in the Start sheet, we can look for the maximum X value and center it over the element width.
If firstshape <> "" Then d = FindXmax() + Sheets("Setup").Shapes("LEVEL_3").Width ActiveSheet.Shapes("N_1").Left = (d - Sheets("Setup").Shapes("LEVEL_1").Width) / 2 End If ActiveSheet.Cells(1, 1).Select
In the last line, we place the cursor on the field at the top left and look forward to a great work breakdown structure.
Perhaps this coding made you want to improve, as Paul Aker and I did a little.
Want to stay informed of future updates? Then subscribe to my blog.