VBA Populating SmartArt and demoting nodes

[Lonuz]

Hi all!

Have to start with a big thank you! I have learnt so much from this forum and wish to contribute in some way in the future! I have been lurking far to long with out creating an account.

To the problem at hand:
I'm building a tool to follow up activities/tasks

I have a table (tabell1) with manually inserted content (tasks) with some dates (start, finish, last follow up, next follow up) and so on.
To this table i use 3 slicers to sort out what to look at. So far pretty easy.
But i then want to populate the content of the table in a SmartArt (Arrow design) called "Diagram 12", based on the content in the table shown with slicers. The parent (level 1) should present the activity(Column 4 in the table) and then create a child(Level 2) with the next follow up date (column 11 in the table) and then.

When i populate the SmartArt i should also clear/delete the existing nodes and then fill it up with the new ones.

I think i have solved the slicer problem, but the main problem is with demoting the nodes. It works sometimes, some times it just crashes Excel.

Here's the code so far.

Sub Fyll()
Dim sheet As Worksheet
Dim table As ListObject
Dim qShape As Shape
Dim lastRow As Range
Dim Values As Variant
Dim TableName As String
Dim i As Integer
Dim y As Integer
Dim count_node As Integer
Dim counter As Integer
Dim count_array As Integer
Dim arr(1 To 50) As String

count_array = ActiveWorkbook.SlicerCaches("Utsnitt_Kluster").VisibleSlicerItems.Count

With ActiveWorkbook.SlicerCaches("Utsnitt_Kluster")
    For counter = 1 To count_array
        arr(counter) = .VisibleSlicerItems(counter).Name
    Next counter
End With

TableName = "Tabell1"
Set sheet = ActiveWorkbook.Worksheets("Data")
Set table = sheet.ListObjects.Item(TableName)
Set qShape = ActiveSheet.Shapes("Diagram 12")
Set lastRow = table.ListRows(table.ListRows.Count).Range


count_node = qShape.SmartArt.Nodes.Count
    
For i = 1 To count_node * 2 'Needs x2 because antal only seemes to look at parrents (dont know why?)
    qShape.SmartArt.AllNodes(1).Delete
Next i
    
For i = 1 To table.ListRows.Count
    For y = LBound(arr) To UBound(arr)
        If table.DataBodyRange(i, 2).Value = arr(y) Then 'Check if node should be created
            qShape.SmartArt.Nodes.Add.TextFrame2.TextRange.Text = table.DataBodyRange(i, 4).Value 'Get text to node 1
            qShape.SmartArt.Nodes.Add.TextFrame2.TextRange.Text = table.DataBodyRange(i, 11).Value 'Get test to node 2
            qShape.SmartArt.AllNodes(i * 2).Demote 'Demote node 2 to child
            y = 50
        End If
    Next y
Next i

End Sub

Have checked both Org Chart from data with level numbers and Organization chart with VBA – Part 2 But i don't really understand how to apply it in this situation.

The arrow should look something like this in the end.

 

[Lonuz]

Solved it! (i think)

The crashing problem was in this:

count_node = qShape.SmartArt.Nodes.Count

For i = 1 To count_node * 2 'Needs x2 because antal only seemes to look at parrents (dont know why?)
    qShape.SmartArt.AllNodes(1).Delete
Next i

Excel apparently crashes when you try to delete a node that doesn't exist.

This works better (probably not the most efficient)

'Count all nodes
count_node = qShape.SmartArt.AllNodes.Count

'Delete all nodes
For i = 1 To count_node
    If count_node > 0 Then
        qShape.SmartArt.AllNodes(1).Delete
    End If
Next i

I also cleaned up a bit and commented. Hope someone has some use for it!

Sub Fyll()
Dim sheet As Worksheet
Dim table As ListObject
Dim qShape As Shape
Dim lastRow As Range
Dim Values As Variant
Dim TableName As String
Dim i As Integer
Dim y As Integer

Dim count_node As Integer
Dim counter As Integer
Dim count_array As Integer
Dim arr(1 To 50) As String

Dim ParNode As SmartArtNode
Dim ChildNode As SmartArtNode

'Get the number of visible slicers
count_array = ActiveWorkbook.SlicerCaches("Utsnitt_Kluster").VisibleSlicerItems.Count

'Get an array with all the names of the slicers
With ActiveWorkbook.SlicerCaches("Utsnitt_Kluster")
    For counter = 1 To count_array
        arr(counter) = .VisibleSlicerItems(counter).Name
    Next counter
End With

'Setting up objects
TableName = "Tabell1"
Set sheet = ActiveWorkbook.Worksheets("Data")
Set table = sheet.ListObjects.Item(TableName)
Set qShape = ActiveSheet.Shapes("Diagram 12")
Set lastRow = table.ListRows(table.ListRows.Count).Range

'Count all nodes
count_node = qShape.SmartArt.AllNodes.Count

'Delete all nodes
For i = 1 To count_node
    If count_node > 0 Then
        qShape.SmartArt.AllNodes(1).Delete
    End If
Next i

'Create nodes in and populate with data from table
For i = 1 To table.ListRows.Count                           'loop throught the table
    For y = LBound(arr) To UBound(arr)                      'loop throught the array
        If table.DataBodyRange(i, 2).Value = arr(y) Then    'Check if the name in table is in the sliced array and then adds a parrent and a demoted child node
            Set ParNode = qShape.SmartArt.Nodes.Add
            ParNode.TextFrame2.TextRange.Text = table.DataBodyRange(i, 4).Value
            Set ChildNode = qShape.SmartArt.Nodes.Add
            ChildNode.TextFrame2.TextRange.Text = table.DataBodyRange(i, 11).Value
            ChildNode.Demote
            y = 50      'ends the loop
        End If
    Next y
Next i

End Sub

 

[PaulStSmith]

I stumbled upon this thread while looking for things related to SmartArtNodes.

I saw a little error on the code above and decided to correct it.

The lines

'Delete all nodes
For i = 1 To count_node
    If count_node > 0 Then
        qShape.SmartArt.AllNodes(1).Delete
    End If
Next i

Should have been:

'Delete all nodes
Do While qShape.SmartArt.AllNodes.Count > 0
    qShape.SmartArt.AllNodes(1).Delete
Loop

This would fix the problem.