- Excel Version
- 2016
- This is a continuation of the article mentioned below; instead of updating, I decided to create another one.
- Now there is an option to make a top to bottom chart.
- As before, the source table goes on a sheet named “fshap”.
- You need to insert two sheets named “tdata” and “secdata”.
VBA Code:
Dim h%, w%
Sub main() ' run me
Dim i%, ob As Worksheet, dt As Worksheet, r As Range, tb As Shape
Set dt = Sheets("tdata")
Set ob = Sheets("fshap")
h = 1
w = 1
Set tb = dt.Shapes.AddTextbox(msoTextOrientationHorizontal, 500, 70, 50, 50)
tb.TextFrame2.TextRange.Text = "Milou"
tb.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
tb.TextFrame2.WordWrap = msoFalse
tb.TextFrame2.TextRange.Font.Size = 16
For i = 1 To ob.Range("a" & Rows.Count).End(xlUp).Row ' determine big shape size
tb.TextFrame2.TextRange.Text = Cells(i, 1) & vbLf & Cells(i, 3)
If tb.Height > h Then h = tb.Height
If tb.Width > w Then w = tb.Width
Next
Application.CutCopyMode = 0
dt.Cells.ClearContents
ob.[a1].CurrentRegion.Copy ' original table
Sheets("secdata").[bb1].PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
For i = ob.Shapes.Count To 1 Step -1
ob.Shapes(i).Delete
Next
ob.Activate
Phase1
Phase2 True, False ' move shapes
Phase2 False, False ' update table
Phase3
Sheets("secdata").[bb1].CurrentRegion.Copy
ob.Range("a1").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, False, False
Set r = dt.Range("b:b").Find(WorksheetFunction.Min(dt.[b:b]), dt.[b1], xlValues, xlWhole)
ob.Rows(CStr(Split(ob.[a1].CurrentRegion.Address, "$")(4) + 2) & ":" & _
CStr(Split(ob.Shapes(r.Offset(, -1)).TopLeftCell.Address, "$")(2) - 2)).Delete ' rows above chart
GroupShapes True ' top to bottom
End Sub
Sub Phase3() ' draws connectors
Dim v, r As Range, lasto%, i%, y1, y2, yf, x1, x2, ws As Worksheet, _
dt As Worksheet, j%, boss$, nr%
Set ws = Sheets("fshap")
Set dt = Sheets("tdata")
dt.[a1:ab70].ClearContents
ws.[a1].CurrentRegion.Copy dt.[a1]
dt.Activate
[g1] = [b1]
v = Split([a1].CurrentRegion.Address, "$")(4)
Range("b1:b" & v).AdvancedFilter xlFilterCopy, [g1:g2], [k1], True
For j = 2 To Range("k" & Rows.Count).End(xlUp).Row
[m1:z70].ClearContents
[m1] = [g1]
[m2] = Cells(j, "k")
Range("a1:b" & v).AdvancedFilter xlFilterCopy, [m1:m2], [n1], False
Set r = [d:d].Find([m2], [d1], xlValues, xlPart)
[q1] = [d74]
[q2] = "*" & [m2] & "*"
nr = Range("n" & Rows.Count).End(xlUp).Row
For i = 2 To nr
Cells(i + 1, "q") = "*" & Cells(i, "n") & "*"
Next
lasto = Split(Range("q1").CurrentRegion.Address, "$")(4)
Range("a74:g" & Range("a" & Rows.Count).End(xlUp).Row).AdvancedFilter _
xlFilterCopy, Range("q1:q" & lasto), [s1], False
y1 = WorksheetFunction.Min([t:t]) + WorksheetFunction.Max([w:w])
yf = y1 + (WorksheetFunction.Max([t:t]) - y1) / 2
x1 = WorksheetFunction.Min([u:u]) + WorksheetFunction.Max([y:y]) / 2
x2 = WorksheetFunction.Max([u:u]) + WorksheetFunction.Max([y:y]) / 2
With ws.Shapes.AddLine(x1, yf, x2, yf).Line ' horizontal
.DashStyle = msoLineSolid
.ForeColor.RGB = RGB(50, 40, 130)
.Weight = 2
End With
Set r = Range("v:v").Find([m2], [v1], xlValues, xlPart)
x1 = r.Offset(, -1) + r.Offset(, 3) / 2
Set r = dt.[f:f].Find(1, dt.[f1], xlValues, xlWhole) ' level one
boss = r.Offset(, -5)
If [m2] = r.Offset(, -2) And nr Mod 2 = 0 Then ' big boss
dt.[u:u].Copy dt.[aa1]
Set r = dt.Range("aa:aa").Find(r.Offset(, -3), dt.[aa1], xlValues, xlWhole)
r = 10000 ' big number
Sorter "aa", 2, dt
ws.Shapes(boss).Left = dt.Cells(4 + (Range("aa" & Rows.Count).End(xlUp).Row - 5) / 2, "aa")
x1 = ws.Shapes(boss).Left + ws.Shapes(boss).Width / 2
End If
With ws.Shapes.AddLine(x1, yf, x1, WorksheetFunction.Max([t:t])).Line ' father to horizontal line
.DashStyle = msoLineSolid
.ForeColor.RGB = RGB(50, 40, 130): .Weight = 2
End With
For i = 2 To Range("n" & Rows.Count).End(xlUp).Row ' sons to horizontal line
Set r = Range("v:v").Find(Cells(i, "n").Value, [v1], xlValues, xlPart)
x1 = r.Offset(, -1) + r.Offset(, 3) / 2
With ws.Shapes.AddLine(x1, r.Offset(, -2) + r.Offset(, 1), x1, yf).Line
.DashStyle = msoLineSolid
.ForeColor.RGB = RGB(50, 40, 130)
.Weight = 2
End With
Next
Next
On Error Resume Next
For i = 1 To ws.Shapes.Count
If Not ws.Shapes(i).TextFrame2.TextRange.Text Like "*%*" Then _
ws.Shapes(i).TextFrame2.TextRange.Font.Size = 16
Next
On Error GoTo 0
End Sub
Sub Phase1() ' draw original chart
Dim arr(), i%, t
arr = Range([a1].CurrentRegion.Address) ' save original table
[ca:ce].ClearContents
Adjust
CreateDiagram ActiveSheet, 1.4
[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 Phase2(move As Boolean, geo As Boolean) ' increases vertical spacing
Dim ws As Worksheet, i%, s As Shape, r As Range, lr%, delta, v%, sn As Shape, dt As Worksheet, x, boss$
Set dt = Sheets("tdata"): Set ws = Sheets("fshap")
dt.Activate: dt.Cells.ClearContents
Set r = [a75]
On Error Resume Next
For Each s In ws.Shapes
If Len(s.TextFrame2.TextRange.Text) = 0 Then s.Delete ' connectors
Next
On Error GoTo 0
[a74] = "name": [b74] = "top": [c74] = "left": [d74] = "text": [e74] = "height"
[h74] = "top": [f74] = "level": [g74] = "width"
For i = 1 To ws.Shapes.Count
If Not ws.Shapes(i).Name Like "*aux*" Then
r = ws.Shapes(i).Name
r.Offset(, 1) = Round(ws.Shapes(i).Top, 0)
r.Offset(, 2) = Round(ws.Shapes(i).Left, 0)
r.Offset(, 3) = ws.Shapes(i).TextFrame2.TextRange.Text
r.Offset(, 4) = Round(ws.Shapes(i).Height, 0)
r.Offset(, 6) = Round(ws.Shapes(i).Width, 0)
Set r = r.Offset(1)
End If
Next
lr = Range("b" & Rows.Count).End(xlUp).Row
Range("B74:B" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[h74:h75], _
CopyToRange:=[i74], Unique:=True
Sorter "i", 75, dt
Range("j75:j" & lr).Formula = "=row()-74"
lr = Range("b" & Rows.Count).End(xlUp).Row
Range("f75:f" & lr).Formula = "=match(b75,$i$75:$i$" & lr & ",0)" ' level
If move Then
delta = WorksheetFunction.Max([e:e])
For i = 75 To lr
Set sn = ws.Shapes(Range("a" & i))
sn.Height = h
sn.Width = w
sn.Top = 2000 - delta * Range("f" & i) * 2 ' new vertical position
ws.Shapes(Range("a" & i) & "aux").Top = sn.Top + sn.Height
Next
End If
Set r = Range("f1:f" & lr).Find(1, [f1], xlValues, xlWhole) ' big boss
boss = r.Offset(, -5)
On Error Resume Next
ws.Shapes(boss & "aux").Delete
On Error GoTo 0
[h75] = 2 'level 2
[h74] = [f74]
Range("a74:g" & lr).AdvancedFilter xlFilterCopy, [h74:h75], [L74], False
If geo And move Then ' geometric middle
x = WorksheetFunction.Max([n:n]) - WorksheetFunction.Min([n:n]) + WorksheetFunction.Max([r:r])
ws.Shapes(boss).Left = WorksheetFunction.Min([n:n]) + x / 2 - WorksheetFunction.Max([r:r]) / 2
ElseIf move And Not geo Then ' align to nearest shape
lr = Range("L" & Rows.Count).End(xlUp).Row
Range("s75:s" & lr).Formula = "=abs(n75-" & CInt(ws.Shapes(boss).Left) & ")"
Range("t75:t" & lr).Formula = "=$n75"
Set r = Range("s:s").Find(WorksheetFunction.Min([s:s]), [s1], xlValues, xlWhole)
ws.Shapes(boss).Left = r.Offset(, 1)
End If
End Sub
Sub Sorter(col$, rn%, dt As Worksheet)
Dim lr%
lr = Range(col & Rows.Count).End(xlUp).Row
dt.Sort.SortFields.Clear
dt.Sort.SortFields.Add Key:=dt.Cells(rn, col), SortOn:=xlSortOnValues, _
Order:=2, DataOption:=0
With dt.Sort
.SetRange dt.Range(Cells(rn, col), Cells(lr, col))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
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].PasteSpecial xlPasteAll
Range("b2:b" & lr).Copy
Range("m3").PasteSpecial xlPasteAll
Range("c2:c" & lr).Copy
Range("o3").PasteSpecial xlPasteAll
Range("d2:d" & lr).Copy
Range("n3").PasteSpecial xlPasteAll
Range("e2:e" & lr).Copy
Range("p3").PasteSpecial xlPasteAll
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(Src As Worksheet, factor#)
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
Select Case Val(Application.Version)
Case 15 ' Excel 2013
Set sal = Application.SmartArtLayouts(89)
Set oshp = ws.Shapes.AddSmartArt(sal)
Case 16 ' Excel 2016
Set oshp = ActiveSheet.Shapes.AddSmartArt(Application.SmartArtLayouts _
("urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart"))
End Select
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 Src.Cells(L, 1) <> ""
If Src.Cells(L, 2) = Src.Cells(L, 3) Then
Set QNode = oshp.SmartArt.AllNodes.Add
QNode.TextFrame2.TextRange.Text = Src.Cells(L, 2)
PID = Src.Cells(L, 2) ' parent node
Src.Rows(L).Delete
AddChildNodes QNode, Src, 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")
With Selection
.ShapeRange.IncrementRotation 180
.ShapeRange.ScaleWidth factor, msoFalse, msoScaleFromBottomRight ' overall size
.ShapeRange.ScaleHeight factor, msoFalse, msoScaleFromBottomRight
.Ungroup
End With
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, -2)
.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
Sub GroupShapes(tp As Boolean)
Dim ws As Worksheet
If tp Then
Set ws = Sheets("fshap")
ws.Activate
ws.Shapes.SelectAll
Selection.Group
Selection.ShapeRange.IncrementRotation 180
DoEvents
ws.Shapes(1).IncrementRotation 180
End If
End Sub
