|
excelperfect 引言：本文的代碼整理自mrexcel.com，一個(gè)很好的令人興奮的示例，有興趣的朋友可以仔細(xì)研究。 首先，看看代碼運(yùn)行后的效果，如下圖1所示。 圖1 SmartArt可以創(chuàng)建組織結(jié)構(gòu)圖，但會(huì)有格式限制，本文給出的代碼克服了這一點(diǎn)。 準(zhǔn)備一個(gè)包含如下圖2所示信息的源數(shù)據(jù)表，其中：
圖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 '移動(dòng)形狀 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 '層級(jí)一 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 '父節(jié)點(diǎn)到水平線 With ws.Shapes.AddLine(x1, yf, x1,WorksheetFunction.Max([t:t])).Line .DashStyle = msoLineSolid .ForeColor.RGB = RGB(50, 40, 130): .Weight = 2 End With '子節(jié)點(diǎn)到水平線 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 '層級(jí)二 [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 '對(duì)齊到最近的形狀 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 '調(diào)整的表 [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 '初始節(jié)點(diǎn) oshp.SmartArt.AllNodes(1).Delete Next '查找根節(jié)點(diǎn) 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) '父節(jié)點(diǎn) 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) '當(dāng)前父節(jié)點(diǎn) 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 |
|
|
