Code:

Sub main() ' run me
Dim arr(), i%, t
arr = Range([a1].CurrentRegion.Address) ' save original table
[ca:ce].ClearContents
Adjust
CreateDiagram ActiveSheet
[a:p].ClearContents
[a1].Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr ' original table
On Error Resume Next
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).TopLeftCell = [a1] Then ActiveSheet.Shapes(i).Delete
t = ActiveSheet.Shapes(i).TextFrame2.TextRange.Text
If Len(t) And Not t Like "*%*" Then ActiveSheet.Shapes(i).IncrementRotation 180
Next
On Error GoTo 0
End Sub
Sub Adjust()
Dim lr%, i%
For i = 1 To ActiveSheet.Shapes.Count
ActiveSheet.Shapes(1).Delete
Next
[k:ae].ClearContents
lr = Range("a" & Rows.Count).End(xlUp).Row
[k1] = "Seq": [L1] = "code1": [m1] = "code2"
[L2] = [b2]: [n1] = "info": [o1] = "info2": [p1] = "outline"
[m2] = [b2]: [k2] = 2: [n2] = 0.01: [o2] = "desc0"
Range("a2:a" & lr).Copy [L3]
Range("b2:b" & lr).Copy [m3]
Range("c2:c" & lr).Copy [o3]
Range("d2:d" & lr).Copy [n3]
Range("e2:e" & lr).Copy [p3]
Range("k3:k" & lr + 1).Formula = "=row()"
[a:e].ClearContents
[k1].CurrentRegion.Copy [a1] ' adjusted table
[L2].Interior.Color = RGB(35, 70, 90)
[k1].CurrentRegion.Copy [z100]
End Sub
Sub CreateDiagram(Source As Worksheet)
Dim sal As SmartArtLayout, QNode As SmartArtNode, QNodes As SmartArtNodes, oshp As Shape, L%, _
i%, r As Range, PID$, mn, mx, ws As Worksheet, crar(), c%, ad, v, t, s As ShapeRange, boss
c = 1
ReDim crar(1 To c)
Set ws = ActiveSheet
For i = 1 To ws.Shapes.Count
ws.Shapes(1).Delete
Next
Set sal = Application.SmartArtLayouts(89)
Set oshp = ws.Shapes.AddSmartArt(sal)
oshp.Top = [a50].Top
Set QNodes = oshp.SmartArt.AllNodes
For i = 1 To 5
oshp.SmartArt.AllNodes(1).Delete ' initial nodes
Next
L = 2 ' look for roots
boss = [b2]
Do While Source.Cells(L, 1) <> ""
If Source.Cells(L, 2) = Source.Cells(L, 3) Then
Set QNode = oshp.SmartArt.AllNodes.Add
QNode.TextFrame2.TextRange.Text = Source.Cells(L, 2)
PID = Source.Cells(L, 2) ' parent node
Source.Rows(L).Delete
AddChildNodes QNode, Source, PID
Else
L = L + 1
End If
Loop
oshp.SmartArt.AllNodes(1).TextFrame2.TextRange.Text = boss
oshp.Width = 1000
oshp.Height = 700
oshp.Select
CommandBars.ExecuteMso ("SmartArtConvertToShapes")
Selection.ShapeRange.IncrementRotation 180
Selection.Ungroup
Set r = ws.[a2]
On Error Resume Next
For i = 1 To ws.Shapes.Count
r = ws.Shapes(i).Height
Set r = r.Offset(1)
Next
mn = WorksheetFunction.Min([a:a])
mx = WorksheetFunction.Max([a:a])
For i = ws.Shapes.Count To 1 Step -1
If ws.Shapes(i).Height = mn Then ws.Shapes(i).Delete
If ws.Shapes(i).Height = mx Then
crar(c) = ws.Shapes(i).Name
c = c + 1
ReDim Preserve crar(1 To c)
End If
Next
On Error GoTo 0
For i = LBound(crar) To UBound(crar)
If Len(crar(i)) Then
v = Split(ws.Shapes(crar(i)).TextFrame2.TextRange.Text, vbLf)(0)
Set r = Range("aa:aa").Find(v, [aa1], xlValues, 1)
ad = r.Offset(, 2)
ws.Shapes(crar(i)).Fill.ForeColor.RGB = r.Interior.Color
Set s = ws.Shapes.Range(Array(crar(i)))
s.TextFrame2.TextRange.Font.Bold = msoTrue
s.TextFrame2.TextRange.Font.Name = "+mj-lt"
If r.Offset(, 4) = "O" Then ' outline
With s.Line
.Weight = 4
.Visible = msoTrue
.ForeColor.RGB = RGB(200, 25, 55)
.Transparency = 0.1
End With
End If
ws.Shapes.AddShape(62, 10, 10, ws.Shapes(crar(i)).Width / 2.5, ws.Shapes(crar(i)).Height / 3).Name = _
ws.Shapes(crar(i)).Name & "aux"
With ws.Shapes(ws.Shapes(crar(i)).Name & "aux")
.Left = ws.Shapes(crar(i)).Left
.Top = ws.Shapes(crar(i)).Top + ws.Shapes(crar(i)).Height
.Line.ForeColor.SchemeColor = 1
.Line.Transparency = 1
.Fill.Visible = msoFalse
.TextFrame.Characters.Text = FormatPercent(ad, 0, vbTrue, vbFalse, vbUseDefault)
.TextFrame.Characters(1, Len(ad)).Font.Size = 9
.TextFrame.Characters(1, Len(ad)).Font.ColorIndex = 0
.TextFrame.Characters(1, Len(ad)).Font.Bold = 1
If ad = 0 Then .TextFrame.Characters.Text = "0%"
End With
End If
Next
End Sub
Sub AddChildNodes(QNode As SmartArtNode, Source As Worksheet, PID$)
Dim L%, Found As Boolean, ParNode As SmartArtNode, CurPid$, ad
L = 2
Found = False 'nothing found yet
Do While Source.Cells(L, 1) <> ""
If Source.Cells(L, 3) = PID Then
Set ParNode = QNode
Set QNode = QNode.AddNode(msoSmartArtNodeBelow)
QNode.TextFrame2.TextRange.Text = Cells(L, 2) & vbLf & Cells(L, 5)
CurPid = Source.Cells(L, 2) ' current parent node
If Not Found Then Found = True 'something was found
Source.Rows(L).Delete
AddChildNodes QNode, Source, CurPid
Set QNode = ParNode
ElseIf Found Then 'it's sorted, nothing else can be found
Exit Do
Else
L = L + 1
End If
Loop
End Sub
'*********************

## Like this thread? Share it with others