VBA实战技巧34:使用VBA组织图形1
excelperfect
引言:本文的代码整理自mrexcel.com,一个很好的令人兴奋的示例,有兴趣的朋友可以仔细研究。
首先,看看代码运行后的效果,如下图1所示。
图1
SmartArt可以创建组织结构图,但会有格式限制,本文给出的代码克服了这一点。
准备一个包含如下图2所示信息的源数据表,其中:
列A和列B – 两个元素之间的关系。形状填充颜色将来自列A。
列C – 要显示的描述性文本。
列D – 放置在形状旁边的辅助数据。
列E – 形状是否有轮廓。
图2
VBA代码如下:
Dim h%, w%
'主程序
Sub main()
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
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
Sheets('secdata').[bb1].PasteSpecialPaste:=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
'更新表格
Phase2 False,False
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
End Sub
'绘制连接线
Sub Phase3()
Dim v, r As ange, 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.Copydt.[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
.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)
boss = r.Offset(, -5)
If [m2] = r.Offset(, -2) And nr Mod 2 = 0Then
dt.[u:u].Copy dt.[aa1]
Set r = dt.Range('aa:aa').Find(r.Offset(, -3), dt.[aa1],xlValues, xlWhole)
r = 10000
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
.DashStyle = msoLineSolid
.ForeColor.RGB = RGB(50, 40, 130): .Weight = 2
End With
'子节点到水平线
For i = 2 To Range('n' &Rows.Count).End(xlUp).Row
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 Tows.Shapes.Count
If Notws.Shapes(i).TextFrame2.TextRange.Text Like '*%*' Then _
ws.Shapes(i).TextFrame2.TextRange.Font.Size= 16
Next
On Error GoTo 0
End Sub
'绘制原始图
Sub Phase1()
Dim arr(), i%,t
'保存原始表
arr =Range([a1].CurrentRegion.Address)
Adjust
CreateDiagram ActiveSheet, 1.4
[a:p].ClearContents
'原始表
[a1].Resize(UBound(arr,1), UBound(arr, 2)).Value = arr
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)
Dim ws As Worksheet, i%, s As Shape, r As Range, lr%, delta, v%, sn As Shape, dt AsWorksheet, 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
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)'
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
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)
boss =r.Offset(, -5)
On Error Resume Next
ws.Shapes(boss& 'aux').Delete
On Error GoTo0
'层级二
[h75] = 2
[h74] = [f74]
Range('a74:g'& lr).AdvancedFilter xlFilterCopy, [h74:h75], [L74], False
'几何中间
If geo And move Then
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
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.AddKey:=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].PasteSpecialxlPasteAll
Range('b2:b'& lr).Copy
Range('m3').PasteSpecialxlPasteAll
Range('c2:c'& lr).Copy
Range('o3').PasteSpecialxlPasteAll
Range('d2:d'& lr).Copy
Range('n3').PasteSpecialxlPasteAll
Range('e2:e'& lr).Copy
Range('p3').PasteSpecialxlPasteAll
Range('k3:k'& lr + 1).Formula = '=row()'
[a:e].ClearContents
'调整的表
[k1].CurrentRegion.Copy[a1]
[L2].Interior.Color= RGB(35, 70, 90)
[k1].CurrentRegion.Copy[z100]
End Sub
Sub CreateDiagram(Src As Worksheet, factor#)
Dim sal AsSmartArtLayout, 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(1To c)
Set ws =ActiveSheet
For i = 1 Tows.Shapes.Count
ws.Shapes(1).Delete
Next
Select CaseVal(Application.Version)
' Excel 2013
Case 15
Set sal =Application.SmartArtLayouts(89)
Set oshp = ws.Shapes.AddSmartArt(sal)
' Excel 2016
Case 16
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
Next
'查找根节点
L = 2
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)
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
.ShapeRange.ScaleHeight factor, msoFalse,msoScaleFromBottomRight
.Ungroup
End With
Set r =ws.[a2]
On Error Resume Next
For i = 1 Tows.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 Thenws.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
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
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)
'找到一些
If Not Found Then Found = True
Source.Rows(L).Delete
AddChildNodes QNode, Source, CurPid
Set QNode = ParNode
'已排序,找不到其他任何东西
ElseIf Found Then
Exit Do
Else
L = L + 1
End If
Loop
End Sub