Using VBA for Smart Art

ilya2004

Board Regular
Joined
Mar 17, 2011
Messages
135
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:

Code:
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
Code:
oShp.smartart.allnodes(i).Level= x
and
Code:
oShp.smartart.allnodes(i).Promote
or
Code:
.Demote
but I am getting error messages.

Any ideas?
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
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:

Code:
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.
 
Upvote 0
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.
 
Upvote 0
I never did get this to work. Maybe now that you have brought it up again, maybe someone will have an idea.
 
Upvote 0
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,
 
Upvote 0
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
 
Upvote 0
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

Code:
'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:

Code:
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.
 
Upvote 0
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
 
Upvote 0
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

Code:
'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:

Code:
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.
 
Upvote 0
Great post been searching for days on end and could not find a free solution that works as this one.
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,949
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top