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?

 

[ProductionTUBE]

I'm having trouble with this script. I need to represent a child node(second column (ID of current node)) having two or more parent nodes(third column (ID of parent node)). When I use this script and I have a child with two parents it doesn't read it. Is there any way to fix that. I would really appreciate the help.

Thank you for all the help, I've gotten the CreateDiagram script to work, but not sure how to get the recursive function AddChildNodes to work.

 

[baidongyi]

Option Explicit


Sub sTest()
setMacroRunEnvironment True
buildStructureByCompany ThisWorkbook.Names("namCompany").RefersToRange.Value
setMacroRunEnvironment False
MsgBox "Done"
End Sub




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

'Create a smartart shape
Dim oShp As Shape, i As Long
Set oShp = ActiveWorkbook.ActiveSheet.Shapes.AddSmartArt(oSALayout)

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

drawUnderNode oShp.SmartArt.AllNodes(1), strCompany

End Function




Private Function drawUnderNode(objNode As SmartArtNode, strParentCompany As String)


objNode.TextFrame2.TextRange.Text = strParentCompany
Dim colSubCom As Collection
Set colSubCom = colGetSubCompanyList(strParentCompany)

If colSubCom.Count = 0 Then
Exit Function
Else
Dim i As Long, objSubNode As SmartArtNode, strSubCompany As String
For i = 1 To colSubCom.Count
strSubCompany = CStr(colSubCom(i))
Set objSubNode = objNode.AddNode(msoSmartArtNodeBelow, msoSmartArtNodeTypeDefault)
drawUnderNode objSubNode, strSubCompany
showProcess "处理", i, colSubCom.Count
Next i
End If
End Function




Private Function colGetSubCompanyList(strParentCompany As String) As Collection
Dim colResult As Collection
Set colResult = New Collection


Dim loData As ListObject, rngCellData As Range, rngCell As Range
Set loData = ThisWorkbook.Sheets(1).ListObjects(1)

For Each rngCell In loData.DataBodyRange.Columns(3).Cells
If rngCell.Value = strParentCompany Then
colResult.Add rngCell.Offset(0, -2).Value
End If

Next rngCell



Set colGetSubCompanyList = colResult
End Function

 

[bkaracs]

Hi All,

I'm working on an orgchart creation code, I'd like to use SmartArtLayout(89) = Name and Title Organizational Chart.
With Nodes(1).TextFrame2.TextRange.Text I can change the "Name" box, does anyone know how I can change the Text in the "Title" box?

Thanks,
Balazs

 

[keldsor]

Gabriel blow your horn ... this is a hard one ... SmartArt, I mean !

I can't even get started with these samples from this thread - HILFE !!!!!!!!!!!!

I trying to get some SmartArt done in an Excel sheet but done by VBA from Access - all 2010 versions !

I keep getting compile error with the "Application.SmartArtLayouts" - I think I need a REFERENCE - but which one ?

 

[keldsor]

I have tried to insert the code from posting #12 into a Excel workbook and then compile - small errors but I can eliminate them.

I then looked for the references used and secure I have THE SAM REFERENCES in Access.

Copied the code into a module there (in Access) and tried to compile - again error at 'Application.SmartArtLayouts' !!!!

PLEASE TELL ME - What do I mis here ?

 

[keldsor]

You FOOL ... it should be 'Excel.Application.SmartArtLayouts' !!!!!!!!!!!!

 

[luiswinner]

Slightly changed version to be able to select the columns that your data is located

Sub OrgChart()
On Error Resume Next
Dim WorkRng As Range
Dim xMin As Double
Dim oSALayout As SmartArtLayout
Dim QNode As SmartArtNode
Dim QNodes As SmartArtNodes
Dim t As Integer
Dim Line As Integer
Dim PID As String 'identification of parent node
Dim intMgr, intEmp, intLastCol As Integer




xTitleId = "Select Range"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)


xTitleId = "Select Column for Manager to sort"
Set WorkRngMgr = Application.Selection
Set WorkRngMgr = Application.InputBox("Column", xTitleId, WorkRngMgr.Address, Type:=8)


xTitleId = "Select Column for Employee name"
Set workRngEmp = Application.Selection
Set workRngEmp = Application.InputBox("Column", xTitleId, workRngEmp.Address, Type:=8)


xMin = Application.WorksheetFunction.Small(WorkRng, 1) - 1


WorkRng.SpecialCells(xlCellTypeBlanks) = xMin

WorkRng.Sort , Key1:=Cells(WorkRng.Row, WorkRngMgr.Column), Key2:=Cells(WorkRng.Row, workRngEmp.Column), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
WorkRng.Replace What:=xMin, Replacement:="", LookAt:=xlWhole




'----------------------------------
'Start Building charts
'----------------------------------


Set oSALayout = Application.SmartArtLayouts(92) 'reference to organization chart
Set oShp = ActiveWorkbook.ActiveSheet.Shapes.AddSmartArt(Application.SmartArtLayouts( _
"urn:microsoft.com/office/officeart/2005/8/layout/orgChart1"))

Set QNodes = oShp.SmartArt.AllNodes
For i = 1 To 5 'delete all included nodes
oShp.SmartArt.AllNodes(1).Delete
Next

Line = 2
Do While Cells(Line, 1) <> ""
If Cells(Line, WorkRngMgr.Column) = "" Then
Set QNode = oShp.SmartArt.AllNodes.Add
QNode.TextFrame2.TextRange.Text = Cells(Line, 6)
PID = Cells(Line, 2)
Rows(Line).Delete
intMgr = WorkRngMgr.Column
intEmp = workRngEmp.Column
intLastCol = WorkRng.Columns.Count

Call AddChildNodes(QNode, PID, intMgr, intEmp, intLastCol)
Else
Line = Line + 1
End If
Loop
End Sub
Sub AddChildNodes(QNode As SmartArtNode, PID As String, intMgr, intEmp, intLastCol As Integer)
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 Cells(Line, 1) <> ""
If Cells(Line, intMgr) = PID Then
Set ParNode = QNode
Set QNode = QNode.AddNode(msoSmartArtNodeBelow)
QNode.TextFrame2.TextRange.Text = Cells(Line, intEmp)
CurPid = Cells(Line, intEmp)
If Not Found Then Found = True 'something was find
Rows(Line).Delete
Call AddChildNodes(QNode, CurPid, intMgr, intEmp, intLastCol)
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

 

[luiswinner]

Small correction
======================================

Line = 2
intMgr = WorkRngMgr.Column
intEmp = WorkRngEmp.Column
intLastCol = WorkRng.Columns.Count

Do While Cells(Line, 1) <> ""
If Cells(Line, intMgr) = "" Then
Set QNode = oShp.SmartArt.AllNodes.Add
QNode.TextFrame2.TextRange.Text = Cells(Line, intEmp)
PID = Cells(Line, intEmp)
Rows(Line).Delete

Call AddChildNodes(QNode, PID, intMgr, intEmp, intLastCol)

 

[Doflamingo]

Hello @Rahzell, I tried your code with what @ilya2004 wanted to do at the 1st step, which is to create a structure chart with the data where 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.

However, I've just put in my editor the macro Private Sub CreateDiagram(Source As Worksheet) and the other macro and then the other macro Private Sub AddChildNodes(QNode As SmartArtNode, Source As Worksheet, PID As String)

But it doesn't work, I don't know why Excel wants me to create a new macro, at each time I try to make it work it displays ''Macro name''

Any ideas ?

 

[Worf]

This is based on input data shown at post seven:

Sub Main()                      ' run me
CreateDiagram ActiveSheet
End Sub

Private Sub CreateDiagram(Source As Worksheet)
Dim oSALayout As SmartArtLayout, oshp, i%, QNode As SmartArtNode, _
QNodes As SmartArtNodes, Line%, PID$
Set oSALayout = Application.SmartArtLayouts(92) ' 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
Line = 2                                        ' looking for roots
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)             ' parent node
        Source.Rows(Line).Delete
        AddChildNodes QNode, Source, PID
    Else
        Line = Line + 1
    End If
Loop
End Sub

Private Sub AddChildNodes(QNode As SmartArtNode, Source As Worksheet, PID$)
Dim Line%, Found As Boolean, ParNode As SmartArtNode, CurPid$
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)          'ID of current parent node
        If Not Found Then Found = True          'something was found
        Source.Rows(Line).Delete
        AddChildNodes QNode, Source, CurPid
        Set QNode = ParNode
    ElseIf Found Then                           'sorted,so nothing else can be found
        Exit Do
    Else
        Line = Line + 1
    End If
Loop
End Sub