前往小程序,Get更优阅读体验!
立即前往
首页
学习
活动
专区
工具
TVP
发布
社区首页 >专栏 >VBA实战技巧34:使用VBA组织图形1

VBA实战技巧34:使用VBA组织图形1

作者头像
fanjy
发布2021-09-22 10:17:33
1.6K0
发布2021-09-22 10:17:33
举报
文章被收录于专栏:完美Excel

引言:本文的代码整理自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" & 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

本文参与 腾讯云自媒体同步曝光计划,分享自微信公众号。
原始发表:2021-09-08,如有侵权请联系 cloudcommunity@tencent.com 删除

本文分享自 完美Excel 微信公众号,前往查看

如有侵权,请联系 cloudcommunity@tencent.com 删除。

本文参与 腾讯云自媒体同步曝光计划  ,欢迎热爱写作的你一起参与!

评论
登录后参与评论
0 条评论
热度
最新
推荐阅读
领券
问题归档专栏文章快讯文章归档关键词归档开发者手册归档开发者手册 Section 归档