Using VBA for Smart Art

[ilya2004]

Hi Folks,

I am trying to use smart art to dynamically generate org charts based on some cell data. Unfortunately there is not that much on this online. Here is what I have so far:

Dim oSALayout As SmartArtLayout
Set oSALayout = Application.SmartArtLayouts(92) 'Get a reference to the "heirarchy" smartart form.

'Create a smartart shape
Set oShp = ActiveWorkbook.ActiveSheet.Shapes.AddSmartArt(oSALayout)

For i = 1 To 5 'clears all the default excel shapes
oShp.SmartArt.AllNodes(1).Delete
Next


For i = 1 To 22
oShp.SmartArt.AllNodes.Add
oShp.SmartArt.AllNodes(i).TextFrame2.TextRange.Text = " " & Range("D" & i).Value
Next

The individual names are on the current sheet in column D and the level that they should be in the heirarchy is in column A. For some reason, the code as I have it creates the correct number of nodes in the tree, but it only copies about 1/5 of the names and leaves the rest of the cells blank.

Also, I am not sure how to change the level of the nodes to match what it needs to be. I tried to add

oShp.smartart.allnodes(i).Level= x

and

oShp.smartart.allnodes(i).Promote

or

.Demote

but I am getting error messages.

Any ideas?

 

[ilya2004]

I was able to get the text to fill in correctly, however I am still struggling with getting the levels correct. Right now I had the code take everything to "level 1" so it all looks like it flat horizontal line. Then I am trying the following:

For x = 2 To Num
oShp.SmartArt.AllNodes(x - 1).TextFrame2.TextRange.Text = Cells(x, 4).Text
Next
For x = 1 To Num - 1
q = Cells(x + 1, 1).Value
On Error Resume Next

    Do
    oShp.SmartArt.AllNodes(x).Demote
    Loop Until oShp.SmartArt.AllNodes(x - 1).Level = q

Next
End Sub

To no avail, unfortunately.

 

[vdonthi]

Hi ilya2004

I do have similar kind of requirement in our excel model, I tried to use your code and got "user-defined type not defined" compile error: am i doing anything wrong?


thanks,
Vdonthi.

 

[ilya2004]

I never did get this to work. Maybe now that you have brought it up again, maybe someone will have an idea.

 

[vdonthi]

Thanks for quick response

I am getting error on first line when declaring dim of "SmartArtLayout" object in Excel 2007. I hope you have pass through this.

Thanks,

 

[Rahzell]

Hello ilya2004
I have exactly the same problem as you. I tried almost everything,but no results. You wrote, that you've got a code putting everything to "level 1". Could you share a code, please?

Thanks

 

[Rahzell]

I got this work finally. With using recursion it was quite easy. There is my solution in Excel 2010(in 2007 doesn't work):
Example of my input data:
H00;USCR;48513687;Ústavní soud;PESPER01 060920110853;Org
A00;USCR00O0A02J;USCR00O0A02J;0;00;Ústavní soud;
A00;USCR00O0A03E;USCR00O0A02J;1;01;Justice;
A00;USCR00O0A049;USCR00O0A02J;2;02;Generální sekretář;
A00;USCR00O0A054;USCR00O0A02J;3;03;Soudní správa;
A00;USCR00O0A06Z;USCR00O0A03E;1;01;1. senát;
A00;USCR00O0A07U;USCR00O0A03E;2;02;2. senát;
A00;USCR00O0A08P;USCR00O0A03E;3;03;3. senát;
A00;USCR00O0A09K;USCR00O0A03E;4;04;4. senát;
A00;USCR00O0A0AF;USCR00O0A03E;5;05;Funkcionář;
A00;USCR00O0A0Q7;USCR00O0A049;1;20;Generální sekretář;
A00;USCR00O0A0SX;USCR00O0A049;2;30;Analytický odbor;

semicolon represent next column in excel
important is only second column (ID of current node), third column (ID of parent node) and the sixth (name)
Those lines i put into Excel

'Source is current open worksheet, 'Source=ThisWorkbook.Sheets(name of the current list)
Private Sub CreateDiagram(Source As Worksheet)

    Dim oSALayout As SmartArtLayout
    Dim QNode As SmartArtNode
    Dim QNodes As SmartArtNodes
    Dim Line As Integer
    Dim PID As String      'identification of parent node
    
    Set oSALayout = Application.SmartArtLayouts(92) 'reference to organization chart
    Set oShp = ActiveWorkbook.ActiveSheet.Shapes.AddSmartArt(oSALayout)
    
    Set QNodes = oShp.SmartArt.AllNodes
    For i = 1 To 5      'delete all included nodes
        oShp.SmartArt.AllNodes(1).Delete
    Next
    
    'looking for root(s)
    Line = 2
    Do While Source.Cells(Line, 1) <> ""
        If Source.Cells(Line, 2) = Source.Cells(Line, 3) Then
            Set QNode = oShp.SmartArt.AllNodes.Add
            QNode.TextFrame2.TextRange.Text = Source.Cells(Line, 6)
            PID = Source.Cells(Line, 2)
            Source.Rows(Line).Delete
            Call AddChildNodes(QNode, Source, PID)
        Else
            Line = Line + 1
        End If
    Loop

End Sub

And there follows the recursive function:

Private Sub AddChildNodes(QNode As SmartArtNode, Source As Worksheet, PID As String)
    Dim Line As Integer
    Dim Found As Boolean
    Dim ParNode As SmartArtNode
    Dim CurPid As String 'ID of current parent node
    
    Line = 2
    Found = False    'nothing found yet
    Do While Source.Cells(Line, 1) <> ""
        If Source.Cells(Line, 3) = PID Then
            Set ParNode = QNode
            Set QNode = QNode.AddNode(msoSmartArtNodeBelow)
            QNode.TextFrame2.TextRange.Text = Cells(Line, 6)
            CurPid = Source.Cells(Line, 2)
            If Not Found Then Found = True 'something was find
            Source.Rows(Line).Delete
            Call AddChildNodes(QNode, Source, CurPid)
            Set QNode = ParNode
        ElseIf Found Then    'it's sorted,so nothing else can be found
            Exit Do
        Else
            Line = Line + 1
        End If
    Loop
    
End Sub

Maybe it looks complicated,but it works. Hope this helps to someone.

 

[Gregg141]

Digging up an old thread here but was anyone able to get this to work on Excel 2007?

Been trying to do so for awhile now but haven't gotten any results

 

[rjanca74337]

Ahoj, and Jak se Mas!

(I am guessing that I am talking to a Czech? Muj ceske i velmi spatny - mluvit anglicky?)

So I am having trouble in that the recursion seems to crash when building child nodes onto nodes one level below the root - did you experience the same issue?

Please advise, Prosim!

Thank you and Dekuji!

- Rob

I got this work finally. With using recursion it was quite easy. There is my solution in Excel 2010(in 2007 doesn't work):
Example of my input data:
H00;USCR;48513687;Ústavní soud;PESPER01 060920110853;Org
A00;USCR00O0A02J;USCR00O0A02J;0;00;Ústavní soud;
A00;USCR00O0A03E;USCR00O0A02J;1;01;Justice;
A00;USCR00O0A049;USCR00O0A02J;2;02;Generální sekretář;
A00;USCR00O0A054;USCR00O0A02J;3;03;Soudní správa;
A00;USCR00O0A06Z;USCR00O0A03E;1;01;1. senát;
A00;USCR00O0A07U;USCR00O0A03E;2;02;2. senát;
A00;USCR00O0A08P;USCR00O0A03E;3;03;3. senát;
A00;USCR00O0A09K;USCR00O0A03E;4;04;4. senát;
A00;USCR00O0A0AF;USCR00O0A03E;5;05;Funkcionář;
A00;USCR00O0A0Q7;USCR00O0A049;1;20;Generální sekretář;
A00;USCR00O0A0SX;USCR00O0A049;2;30;Analytický odbor;

semicolon represent next column in excel
important is only second column (ID of current node), third column (ID of parent node) and the sixth (name)
Those lines i put into Excel

'Source is current open worksheet, 'Source=ThisWorkbook.Sheets(name of the current list)
Private Sub CreateDiagram(Source As Worksheet)

    Dim oSALayout As SmartArtLayout
    Dim QNode As SmartArtNode
    Dim QNodes As SmartArtNodes
    Dim Line As Integer
    Dim PID As String      'identification of parent node
    
    Set oSALayout = Application.SmartArtLayouts(92) 'reference to organization chart
    Set oShp = ActiveWorkbook.ActiveSheet.Shapes.AddSmartArt(oSALayout)
    
    Set QNodes = oShp.SmartArt.AllNodes
    For i = 1 To 5      'delete all included nodes
        oShp.SmartArt.AllNodes(1).Delete
    Next
    
    'looking for root(s)
    Line = 2
    Do While Source.Cells(Line, 1) <> ""
        If Source.Cells(Line, 2) = Source.Cells(Line, 3) Then
            Set QNode = oShp.SmartArt.AllNodes.Add
            QNode.TextFrame2.TextRange.Text = Source.Cells(Line, 6)
            PID = Source.Cells(Line, 2)
            Source.Rows(Line).Delete
            Call AddChildNodes(QNode, Source, PID)
        Else
            Line = Line + 1
        End If
    Loop

End Sub

And there follows the recursive function:

Private Sub AddChildNodes(QNode As SmartArtNode, Source As Worksheet, PID As String)
    Dim Line As Integer
    Dim Found As Boolean
    Dim ParNode As SmartArtNode
    Dim CurPid As String 'ID of current parent node
    
    Line = 2
    Found = False    'nothing found yet
    Do While Source.Cells(Line, 1) <> ""
        If Source.Cells(Line, 3) = PID Then
            Set ParNode = QNode
            Set QNode = QNode.AddNode(msoSmartArtNodeBelow)
            QNode.TextFrame2.TextRange.Text = Cells(Line, 6)
            CurPid = Source.Cells(Line, 2)
            If Not Found Then Found = True 'something was find
            Source.Rows(Line).Delete
            Call AddChildNodes(QNode, Source, CurPid)
            Set QNode = ParNode
        ElseIf Found Then    'it's sorted,so nothing else can be found
            Exit Do
        Else
            Line = Line + 1
        End If
    Loop
    
End Sub

Maybe it looks complicated,but it works. Hope this helps to someone.

 

[BLawry]

Great post been searching for days on end and could not find a free solution that works as this one.