Blog

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:

Work breakdown structure / WBS in 3 minutes

Work Breakdown Structure with automatic progress visualization

What is happening?

Before we start, let’s take a look at the slow motion variant of the macro.

1. Delete current work breakdown structure
2. Get start setup
3. Build the work breakdown structure line by line and calculate positions and insert shapes
4. 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 1.2.2.2.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

Almost there!

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.

Stay active!

How To Create An Automatic Visual Work Breakdown Structure from Thomas Angielsky

Download

Want to stay informed of future updates? Then subscribe to my blog.

Download:
Automatic_WBS.xlsm

Links

E-Book 2 Second Lean

Youtube Videos von FASTCAP

Article Work Breakdown Structure 3 minutes

Article Work Breakdown Structure with automatic progress visualization

---

Hier klicken, um den Artikel in Deutsch zu lesen.