Excel Makro: Automatischer Projektstrukturplan

Wie erstellt man mit Excel Makros automatisch einen Projektstrukturplan? Das geht gar nicht so schwer und bringt Ihnen dauerhaft ungeahnte Zeiteinsparungen.

Vor 4 Jahren habe ich zum ersten Mal das Buch von Paul A. Akers 2 Second Lean gelesen. Bei Paul dreht sich alles um stetige Verbesserung. Das Buch handelt von seiner Lean Reise: einmal für ihn persönlich und einmal mit seiner Firma. Sie können sich die zahlreichen Videos bei Youtube anschauen. Ich las es damals noch in Englisch – fand es aber so unterhaltsam geschrieben, dass ich es in einem Rutsch an zwei Tagen gelesen habe.

Paul Aker schreibt:

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

Das hat mich damals ziemlich beeindruckt. Jeden Tag eine Verbesserung, die nur 2 Sekunden einspart. Das klingt am Anfang nach extrem wenig, hat aber riesige Auswirkungen. Seitdem verbessere ich auch in kleinen Schritten meine Arbeitsabläufe.

Und in diesem 2-Second-Lean geht es um die automatische Erstellung von Projektstrukturplänen.

Die Funktion können Sie sich in den beiden Artikeln anschauen:

Was passiert?

Bevor es losgeht, schauen wir uns die Slow-Motion Variante des Makros an.

Aktuellen Projektstrukturplan löschen
Einstellung holen
Projektstrukturplan zeilenweise aufbauen und Positionen berechnen und Shapes einfügen
Oberstes Shape zentrieren

Erst mal alles löschen

Zuerst wird ein evtl. bereits vorhandener PSP gelöscht. Der Plan wird vollständig über Shape-Elemente aufgebaut: Rechtecke und Verbindungslinien. Alle Elemente bekommen ein Kennzeichen über den Namen mit. Sie beginnen mit N_. Deswegen ist es möglich, sie einfach über den Namen zu finden und zulöschen.

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

Der automatische Aufbau des Projektstrukturplans wird über die Sub CreateWorkBreakdownStructure durchgeführt.

Zuerst holen wir uns die Einstellungen, die in der Tabelle Setup hinterlegt sind. Die entsprechenden Zellen haben einen Namen bekommen. Dadurch können wir die Werte immer finden, auch wenn sich die Zellposition mal ändert.

Der Zugriff auf einen Wert geht über das Range-Objekt. Basis ist immer die jeweilige Tabelle. Bei uns ist das 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")

Danach initialisieren wir noch ein paar Variablen mit Ihren Startwerten und beginnen mit der Hauptschleife.

Den WBS-PSP Code knacken

Jetzt geht es um Codes. Ich bin im Coding in der englischen Sprache geblieben. Deswegen heißt der PSP-Code, hier WBS-Code (work breakdown structure).

Diesen Code holen wir uns jetzt über die Hauptschleife. In dieser werden alle Einträge aus der Tabelle Start durchlaufen. Der steuernde Wert steht in der Spalte Code. Den lesen wir über das Objekt Cells(Zeile, Spalte) in eine Variable wbsCode ein.

  Do
    wbsCode = Sheets("Start").Cells(row, COL_CODE)
    wbsCodeParent = GetParentWBS(wbsCode)
    pParent = GetLastPosition(wbsCodeParent)

Damit wir wissen an welcher Hierachieebene und Position das neue Elemente angeordnet werden soll, brauchen wir auch das Eltern-Element dazu. Das ermitteln wir über eine eigene Funktion GetParentWBS(wbsCode) und übergeben unseren PSP-Code als Parameter.

Die Strukturierung des PSP-Codes erfolgt über Punkte. Um das Eltern-Element zu finden, müssen wir den PSP-Code von rechts durchlaufen, bis wir einen Punkt finden. Dann können wir den Teilstring von links ausgehend bis zu dieser Position-1 als Ergebnis zurück liefern.

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

Die letzte Position

Haben wir das Eltern-Element gefunden, holen wir uns die aktuellen Positionsdaten. Das machen wir auch mit einer eigenen Funktion. Ich habe sie GetLastPosition genannt.

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

Die Funktion durchläuft genauso, wie die Hauptschleife alle Elemente in der Tabelle Start. Sie schaut dabei in die berechneten Spalten X, Y und Count. Wie diese berechnet werden? Später mehr.

Die drei Werte werden als Ergebnis zurück geliefert. Dafür gibt es einen eigenen Datentyp Position.

Type Position
  x As Double
  y As Double
  count As Integer
End Type

Mit dieser Positionsinformation (gespeichert in der Variable pParent) des Eltern-Elements kommen wir dann wieder zurück in die Hauptschleife.

Jetzt kommt Struktur

Unser Projektstrukturplan bekommt jetzt seine Struktur. In der Tabelle Setup können die ersten 3 Ebenen (Levels) frei formatiert werden. Diese Level müssen wir jetzt im Quellcode erkennen und entsprechend den Parameter, die wir bei Programmstart gelesen haben, positionieren.

Um den Level zu erkennen, zählen wir einfach die Punkte im PSP-Code. Das macht die Funktion CountPoints. 0 Punkte entspricht der obersten Ebene, 1 Punkt der zweiten. Für alle weiteren gilt die Formatierung der Ebene 3.

In den If-Abfragen der Level, holen wir uns weitere spezifische Parameter des Levels, wie Elementbreite oder Elementhöhe. Und natürlich auch den Ausgabetext.

Unser Projektstrukurplan besteht aus Rechteck-Shapes. Auf diese greifen wir in VBA mit dem Objekt Shapes(Name) zu. Den Namen hat das Shape in der Tabelle Setup vorher manuell bekommen.

Damit wir ein neues Shape auch richtig positionieren können, speichern wir die aktuelle Position über die Variable p. Sie ist auch vom Typ Position.

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

Mit den obigen Zeilen haben wir für das aktuelle Element für jeden möglichen Level die Position berechnet. Wir haben die geplante Höhe und Breite in den Variablen h und w gespeichert. Und der Titel ist in der Variable caption abgelegt.

Mit den folgenden Zeilen speichern wir uns die berechnete Position zum jeweiligen Element in der Tabelle Start ab. Sie werden dort als Spalte X, Y und Count abgelegt.

Alles wird gespeichert

Das machen wir auf drei Arten. Der Aufbau des Projektstrukturplans kann sehr groß sein und viele Levels enthalten. Bauen wir aber einen neuen Zweig der zweiten Ebene auf, brauchen wir die max. Position des Eltern-Elements. Deshalb speichern wir für alle Elemente auf der Eltern-Ebene die aktuelle X Position, sozusagen als maximaler Wert ab.

    p.count = pParent.count + 1
    Call SetPositions(wbsCodeParent, p)
    
    Call SetPosition(wbsCodeParent, p)
    
    p.count = 0
    Call SetPosition(wbsCode, p)

Und nochmal speichern

Was passiert nun alles in der Prozedur SetPositions? Es werden wieder alle Element der Tabelle Start durchlaufen. Zuerst holen wir uns aber den PSP-Code des zweiten Levels, z. B. 1.2 aus 1.2.2.2.1.

Das ist nämlich unser Zweig. Unter diesem werden alle Elemente untereinander angeordnet, wie die Elemente im Windows Explorer. Beim Durchlaufen setzen wir die Y Koordinate bei allen Elemente gleichen Level auf den neuen Wert.

Sub SetPositions(wbsCode As String, p As Position)
Dim row As Integer
Dim result As Position
Dim w As String
Dim wbsLevel2 As String

  wbsLevel2 = GetLevel2WBS(wbsCode)
  
  row = ROW_START
  Do
    w = Sheets("Start").Cells(row, COL_CODE)
    If (wbsCode = w) Or ((wbsLevel2 = Left$(w, Len(wbsLevel2))) And (wbsLevel2 <> "")) Then
      Sheets("Start").Cells(row, COL_COUNT) = p.count
      Sheets("Start").Cells(row, COL_Y) = p.y
    End If

    row = row + 1
  Loop Until w = ""
End Sub

Bei der Prozedur SetPosition passiert fast das gleiche, nur wird hier auch die X Koordinate und Count gespeichert.

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

Jetzt kommt die Beschriftung

Zurück in der Hauptschleife sind jetzt die Positionen gespeichert und können beim nächsten Durchlaufen als neue Position wieder gelesen werden.

Wir kümmern uns beim nächsten Schritt um die Beschriftung unseres PSP. In der Variable caption ist der Text auch als Variable abgelegt. Diese Variablen ersetzen wir jetzt mit den Daten aus Tabelle Start.

Zuerst prüfen wir, ob der Benutzer die Fortschrittsformatierung haben möchte. Wenn Ja, holen wir uns das entsprechende Format für den jeweiligen Leven in die Variable caption. Wenn nein, bleibt caption wie es war.

    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

Im nächsten Schritt ersetzen wir die internen Variablen mit den Daten aus Tabelle Start. Das geht über die VBA Funktion 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 und Connectors

Dann kommt endlich der spannende Teil. Wir erzeugen uns ein Rechteck und fügen es ein.

    Call InsertRectangle(wbsCode, caption, p.x, p.y, w, h, level, progress)
    If level > 0 Then Call InsertConnector(wbsCodeParent, wbsCode, level)

Das machen wir auch über eine eigene Prozedure InsertRectangle. Das Einfügen soll auf das aktuelle Tabellenblatt erfolgen, deshalb nutzen wir ActiveSheet.

Ein neues Shape wird über die Methode Shapes.AddShape eingefügt. Sie müssen aber nicht unbedingt ein Rechteck-Shape nehmen.

Unter https://docs.microsoft.com/de-de/office/vba/api/office.msoautoshapetype finden Sie die Namen der weiteren Möglichkeiten.

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

Als Namen verwenden wir wieder den PSP-Code. Wir stellen ihm aber den Text „N_“ voran.

Um die Formatierung aus dem Tabellenblatt Setup zu bekommen, nutzen wir die Excel Funktion Format übertragen. Das geht mit dem Befehl Sheets(Name).Shapes(Name).PickUp und das Übertragen mit 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

Danach erfolgt im Quellcode die Entscheidung, ob nach Fortschritt formatiert werden soll. Wenn Ja, werden die Farbeinstellungen entsprechend wieder gelesen und dem Shape Interior.Color übergeben.

Am Schluss wird noch der Titel des Shapes angepasst.

Das Einfügen der Verbindungslinien erfolgt nach dem gleichen Schema. Als Kontaktpunkte nutzen wir die Namen der Rechteck-Elemente. Und die kennen wir über den PSP-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

Fast geschafft!

Am Ende der Hauptschleife prüfen wir noch, ob das eingefügte Element das erste war und merken uns den PSP-Code. Das brauchen wir am Ende, um das Element zu zentrieren.

Dann bereiten wir alles für den nächsten Durchlauf vor: row hochzählen, Level und PSP-Code merken – fertig für das nächste 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 = ""

Am Schluss kommt noch das Zentrieren des ersten Elements. Da wir alle X Werte in der Tabelle Start gespeichert haben, können wir uns den maximalen X Wert suchen und über die Element-Breite zentrieren.

  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 der letzten Zeile stellen wir den Cursor noch auf das Feld links oben und freuen uns über einen tollen Projektstrukturplan.

Vielleicht hat dieses Coding bei Ihnen die Lust zum Verbessern, wie bei Paul Aker und mir ein wenig entfacht.

Bleiben Sie dran!