Sub AddChildren(ByVal QParent As SmartArtNode, ByVal Code As String)
Dim Level As Long
Dim v As Variant
Dim r As Long
Dim QChild As SmartArtNode
' Dissect the code
v = Split(Code, ".")
' Next level
Level = UBound(v) + 2
' Loop through the rows
For r = 2 To Range("A1").End(xlDown).Row
' Look for correct level and code
If Range("C" & r).Value = Level And Range("G" & r + 1).Value Like Code & ".*" Then
' Create new node
Set QChild = QParent.AddNode(msoSmartArtNodeBelow)
' Set node properties
With QChild.TextFrame2.TextRange
.Text = Range("B" & r).Value
.Font.Fill.ForeColor.RGB = Range("C" & r).Font.Color
.Font.Size = 7
.Font.Italic = Range("C" & r).Font.Italic
If Range("C" & r).Font.Underline = xlUnderlineStyleSingle Then
.Font.UnderlineColor = Range("C" & r).Font.Color 'hier wird die Schriftfarbe ?bernommen
.Font.UnderlineStyle = msoUnderlineSingleLine 'hier kommt unterstrichen?
End If
.Font.Strikethrough = Range("C" & r).Font.Strikethrough 'hier kommt durchgestrichen?
'.Font.FontStyle = Range("C" & r).Font.FontStyle
.Font.Bold = Range("C" & r).Font.Bold
End With
QChild.Shapes(1).Fill.ForeColor.RGB = Range("C" & r).Interior.Color
' Recursion!
Call AddChildren(QChild, Range("G" & r + 1).Value)
End If
Next r
End Sub
Sub AddChildren(ByVal QParent As SmartArtNode, ByVal Code As String)
Dim Level As Long
Dim r As Long
Dim QChild As SmartArtNode
' Next level
Level = Len(Code) + 1
' Loop through the rows
For r = 2 To Range("A1").End(xlDown).Row
' Look for correct level and code
If Range("C" & r).Value = Level And Range("G" & r + 1).Value Like Code & "*" Then
' Create new node
Set QChild = QParent.AddNode(msoSmartArtNodeBelow)
' Set node properties
With QChild.TextFrame2.TextRange
.Text = Range("B" & r).Value
.Font.Fill.ForeColor.RGB = Range("C" & r).Font.Color
.Font.Size = 7
.Font.Italic = Range("C" & r).Font.Italic
If Range("C" & r).Font.Underline = xlUnderlineStyleSingle Then
.Font.UnderlineColor = Range("C" & r).Font.Color
.Font.UnderlineStyle = msoUnderlineSingleLine
End If
.Font.Strikethrough = Range("C" & r).Font.Strikethrough
.Font.Bold = Range("C" & r).Font.Bold
End With
QChild.Shapes(1).Fill.ForeColor.RGB = Range("C" & r).Interior.Color
' Recursion!
Call AddChildren(QChild, Range("G" & r + 1).Value)
End If
Next r
End Sub
The reason for the complicated code in Stephan Sander's thread is that we couldn't rely on the items being ordered according to the hierarchy. We had to rely on the PSP in column G.
I'll try to come up with an alternative.
In the attachment from post your last post, after the org chart is created, is it possible to move any box that start with CC as an assistant under CC? I guess this could be during the initial build if that works better.
In this case, can the CCF and CCQ be moved as an assistant under the CC?
Const MaxLevel = 2
Sub org()
Dim shp As Shape
Dim ogSALayout As SmartArtLayout
Dim ogShp As Shape
Dim QNodes As SmartArtNodes
Dim QNode As SmartArtNode
Dim t As Long
Dim i As Long
Dim r As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each shp In ActiveSheet.Shapes
If shp.Type = msoSmartArt Then
shp.Delete
End If
Next shp
Set ogSALayout = Application.SmartArtLayouts("urn:microsoft.com/office/officeart/2005/8/layout/orgChart1")
Set ogShp = ActiveSheet.Shapes.AddSmartArt(ogSALayout, 630, 36, 720, 630)
Set QNodes = ogShp.SmartArt.AllNodes
t = QNodes.Count
' Delete all nodes except one
For i = 2 To t
ogShp.SmartArt.Nodes(1).Delete
Next i
' Set root node properties
Set QNode = QNodes(1)
With QNode.TextFrame2.TextRange
.Text = Range("B1").Value
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 8
.Font.Bold = True
End With
QNode.Shapes(1).Fill.ForeColor.RGB = Range("C1").Interior.Color
' Recursively add children nodes
r = 1
Call AddChildren(QNode, r)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub AddChildren(ByVal QParent As SmartArtNode, ByVal r As Long)
Dim Level As Long
Dim s As Long
Dim QChild As SmartArtNode
' Current level
Level = Range("C" & r).Value
If Level = MaxLevel Then Exit Sub
s = r + 1
Do While Range("C" & s).Value > Level And Range("C" & s).Value <> ""
' Look for correct level and code
If Range("C" & s).Value = Level + 1 Then
' Create new node
Set QChild = QParent.AddNode(msoSmartArtNodeBelow)
' Set node properties
With QChild.TextFrame2.TextRange
.Text = Range("B" & s).Value
.Font.Fill.ForeColor.RGB = Range("C" & s).Font.Color
.Font.Size = 7
.Font.Italic = Range("C" & s).Font.Italic
If Range("C" & s).Font.Underline = xlUnderlineStyleSingle Then
.Font.UnderlineColor = Range("C" & s).Font.Color
.Font.UnderlineStyle = msoUnderlineSingleLine
End If
.Font.Strikethrough = Range("C" & s).Font.Strikethrough
.Font.Bold = Range("C" & s).Font.Bold
End With
QChild.Shapes(1).Fill.ForeColor.RGB = Range("C" & s).Interior.Color
' Recursion!
Call AddChildren(QChild, s)
End If
s = s + 1
Loop
End Sub
Change the constant at the beginning if you want to stop at another level.
Hi Hans, I'm back looking for another tweak if possible. I've tried to add this by stepping thru the code and seeing where it could be placed, but honestly, I get confused with the loop.
In this file, column L holds a check mark and it's those records I would like to have skipped in the making of the org chart.
You do not have the required permissions to view the files attached to this post.
The reason for the complicated code in Stephan Sander's thread is that we couldn't rely on the items being ordered according to the hierarchy. We had to rely on the PSP in column G.
I'll try to come up with an alternative.
Hi Hans, the reason for the hierarchy in column G is, that it is based on Jeremy Modjeskas Incredible work on building WBS structures.
First, i build up the WBS structure, then i have copied it into the WBS worksheet, and based on this, i built up with your highly appreciated help a coloured project structure.
Indeed, a built up structure, based on WBS numbers (e.g 1, 1.1, 1.2, 1.2.1 ….) does not provide the cool workout to get an assistant shown in it - as in the provided solution -(i have to do this manually).
