（纯代码）Excel VBA-WE020 21「VBA让你一键生成框架图」

Sub ggg()
MsgBox "框的尺寸，跟[B1]单元格相同"
l = 100
w = [B1].Width
h = [B1].Height
t = h
dw = w / 10
dh = h / 2
Dim d(1 To 10)
Dim zx(1 To 4, 1 To 2) As Single
rmax = [A65535].End(xlUp).Row
For lv = rmax To 1 Step -1
 Set d(lv) = CreateObject("scripting.dictionary")
 For i = 1 To 100 '100可以用所有行的最大列数代替
 If Cells(lv, i).Interior.Color <> 16777215 Then d(lv).Add i, ""
 Next
Next
For lv = 2 To rmax
 fenge = d(lv).keys()
 For g = 0 To d(lv).Count - 2 'g代表灰色间隔
 num = Application.CountA(Range(Cells(lv, fenge(g) + 1), Cells(lv, fenge(g + 1) - 1)))
 zi = fenge(g) + 1 '取j的初始，不能放For循环
 For j = fenge(g) + 1 To fenge(g) + 1 + num - 1 'j代表格子的数量
 x = (fenge(g + 1) - fenge(g)) * (w + dw) - dw 'x确定每组的总宽度
 dw2 = (x - num * w) / (num + 1)
 
 ActiveSheet.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
 Left:=l + (j - 1) * w + fenge(g) * dw + (j - fenge(g)) * dw2, _
 Top:=t + (lv - 1) * (h + dh), Width:=w, Height:=h).Select
 With Selection
 Do While Cells(lv, zi) = ""
 zi = zi + 1
 Loop
 .Characters.Text = Cells(lv, zi)
 zi = zi + 1
 .ShapeRange.Line.Visible = msoTrue
 .ShapeRange.Line.ForeColor.RGB = RGB(50, 0, 128)
 .ShapeRange.Line.Weight = 2
 .HorizontalAlignment = xlCenter
 .VerticalAlignment = xlCenter
 .Font.Size = 10
 .Font.Name = "微软雅黑"
 .Font.Color = RGB(255, 255, 255)
 .Font.Bold = True
 .ShapeRange.Fill.Visible = msoTrue
 .ShapeRange.Fill.ForeColor.RGB = RGB(0, 190, 255)
 End With
 
 '同组互连
 If lv > 1 Then
 zx(1, 1) = l + (j - 1) * w + fenge(g) * dw + (j - fenge(g)) * dw2 + w / 2 'Left值+w/2
 zx(1, 2) = t + (lv - 1) * (h + dh) + 3 ''3微调
 zx(2, 1) = zx(1, 1)
 zx(2, 2) = t + (lv - 1) * (h + dh) - dh / 2
 zx(3, 1) = l + fenge(g) * w + fenge(g) * dw + dw2 + w / 2 'j的初始带入Left，再加w/2
 zx(3, 2) = zx(2, 2)
 zx(4, 1) = zx(3, 1)
 zx(4, 2) = zx(3, 2)
 ActiveSheet.Shapes.AddPolyline(zx).Select
 Selection.ShapeRange.Line.ForeColor.RGB = RGB(50, 0, 128)
 Selection.ShapeRange.Line.Weight = 3
 End If
 
 '连接下层
 numdown = Application.CountA(Range(Cells(lv + 1, fenge(g) + 1), Cells(lv + 1, fenge(g + 1) - 1)))
 If numdown > 0 Then
 zx(1, 1) = l + (j - 1) * w + fenge(g) * dw + (j - fenge(g)) * dw2 + w / 2 'Left值+w/2
 zx(1, 2) = t + (lv - 1) * (h + dh) + h + 2 '上面的加h
 zx(2, 1) = zx(1, 1)
 zx(2, 2) = t + (lv - 1) * (h + dh) + dh / 2 + h '上面的加h，-dh/2改为+dh/2
 zx(3, 1) = l + fenge(g) * w + fenge(g) * dw + dw2 + w / 2 'j的初始带入Left，再加w/2
 zx(3, 2) = zx(2, 2)
 zx(4, 1) = zx(3, 1)
 zx(4, 2) = zx(3, 2)
 ActiveSheet.Shapes.AddPolyline(zx).Select
 Selection.ShapeRange.Line.ForeColor.RGB = RGB(50, 0, 128)
 Selection.ShapeRange.Line.Weight = 3
 End If
 Next
 Next
Next
For i = 1 To rmax - 1
 If d(i).Count <> d(i + 1).Count Then
 benzu = d(i).keys '上层
 dizu = d(i + 1).keys '下层
 xiu = 0
 For j = 1 To d(i).Count
 If benzu(j - 1) <> dizu(j - 1 + xiu) Then
 For k = 0 To j - 1
 If benzu(j - 2) = dizu(k + xiu) Then a = k + xiu
 'a是下层的开始。xiu对上下层取值进行修正，避免重复触发
 Next
 For k = j - 1 To d(i + 1).Count - 1
 If benzu(j - 1) = dizu(k) Then
 b = k 'b是下层的结束
 xiu = b - a - 1 + xiu 'xiu对上下层取值进行修正，避免重复触发
 Exit For
 End If
 Next
 
 lv = i + 1
 num = Application.CountA(Range(Cells(lv, dizu(a) + 1), Cells(lv, dizu(a + 1) - 1)))
 x = (dizu(a + 1) - dizu(a)) * (w + dw) - dw
 dw2 = (x - num * w) / (num + 1)
 ss = l + dizu(a) * w + dizu(a) * dw + dw2 + w / 2
 '只跟a有关，j最小值代入left公式，g=a
 
 num = Application.CountA(Range(Cells(lv, dizu(b - 1) + 1), Cells(lv, dizu(b) - 1)))
 x = (dizu(b) - dizu(b - 1)) * (w + dw) - dw
 dw2 = (x - num * w) / (num + 1)
 se = l + (dizu(b - 1) + 1 + num - 1 - 1) * w + dizu(b - 1) * dw + _
 (dizu(b - 1) + 1 + num - 1 - dizu(b - 1)) * dw2 + w / 2
 '只跟b有关，j最大值代入left公式，g=b-1
 
 '同级部门互连线
 zx(1, 1) = ss
 zx(1, 2) = t + h * (lv - 1) + dh * (lv - 2) + dh / 2
 zx(2, 1) = se
 zx(2, 2) = zx(1, 2)
 zx(3, 1) = zx(2, 1)
 zx(3, 2) = zx(2, 2)
 zx(4, 1) = zx(3, 1)
 zx(4, 2) = zx(3, 2)
 ActiveSheet.Shapes.AddPolyline(zx).Select
 Selection.ShapeRange.Line.ForeColor.RGB = RGB(50, 0, 128)
 Selection.ShapeRange.Line.Weight = 3
 
 If i = 1 Then
 lv = i
 zi = benzu(d(lv).Count - 1)
 cmax1 = Cells(1, 15000).End(xlToLeft).Column
 If cmax1 > benzu(d(1).Count - 1) Then '先画总裁助理
 rrr = w '有总裁助理时，rrr用来修正总裁跟下层的连线长度
 num = Application.CountA(Range(Cells(1, benzu(d(1).Count - 1)), Cells(1, cmax1))) '多个助理
 For jj = 1 To num
 ActiveSheet.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
 Left:=ss + (se - ss) / 2 + jj * (h + dw), _
 Top:=t + h - w / 2 + (-rrr + dh / 2) / 2, Width:=h, Height:=w).Select
 With Selection
 Do While Cells(lv, zi) = ""
 zi = zi + 1
 Loop
 .Characters.Text = Cells(lv, zi)
 zi = zi + 1
 .ShapeRange.Line.Visible = msoTrue
 .ShapeRange.Line.ForeColor.RGB = RGB(50, 0, 128)
 .ShapeRange.Line.Weight = 2
 .HorizontalAlignment = xlCenter
 .VerticalAlignment = xlCenter
 .Font.Size = 12
 .Font.Name = "微软雅黑"
 .Font.Bold = True
 .Font.Color = RGB(255, 255, 255)
 .ShapeRange.Line.Style = msoLineThickThin
 .ShapeRange.Fill.Visible = msoTrue
 .ShapeRange.Fill.ForeColor.RGB = RGB(66, 66, 190)
 End With
 
 '总裁助理连线
 If jj = 1 Then
 zx(1, 1) = ss + (se - ss) / 2 + jj * (h + dw) 'Left值
 zx(1, 2) = t + h + (-rrr + dh / 2) / 2
 zx(2, 1) = ss + (se - ss) / 2
 zx(2, 2) = zx(1, 2)
 zx(3, 1) = zx(1, 1)
 zx(3, 2) = zx(2, 2)
 zx(4, 1) = zx(3, 1)
 zx(4, 2) = zx(3, 2)
 ActiveSheet.Shapes.AddPolyline(zx).Select
 Selection.ShapeRange.Line.ForeColor.RGB = RGB(50, 0, 128)
 Selection.ShapeRange.Line.Weight = 3
 End If
 Next
 End If
 
 '第 1 层职位
 zi = benzu(a) + 1
 w = w * 1.2
 h = h * 1.2
 For g = a To b - xiu - 1 'g为间隔点
 num = Application.CountA(Range(Cells(lv, benzu(g) + 1), Cells(lv, benzu(g + 1) - 1)))
 For jj = benzu(g) + 1 To benzu(g) + 1 + num - 1
 x = se - ss
 dw2 = (x - num * w) / (num + 1)
 ActiveSheet.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
 Left:=ss + dw2 + (jj - benzu(g) - 1) * (w + dw2), _
 Top:=t - rrr - 0.2 * h, Width:=w, Height:=h).Select
 With Selection
 Do While Cells(lv, zi) = ""
 zi = zi + 1
 Loop
 .Characters.Text = Cells(lv, zi)
 zi = zi + 1
 .ShapeRange.Fill.Visible = True
 .ShapeRange.Line.Visible = msoTrue
 .ShapeRange.Line.ForeColor.RGB = RGB(50, 0, 128)
 .ShapeRange.Line.Weight = 3
 .HorizontalAlignment = xlCenter
 .VerticalAlignment = xlCenter
 .Font.Size = 14
 .Font.Name = "微软雅黑"
 .Font.Color = RGB(255, 255, 255)
 .Font.Bold = True
 .ShapeRange.Line.Style = msoLineThickThin
 .ShapeRange.Fill.ForeColor.RGB = RGB(0, 166, 255)
 End With
 
 '连接下层
 numdown = Application.CountA(Range(Cells(lv + 1, dizu(g) + 1), Cells(lv + 1, dizu(g + 1) - 1)))
 If numdown > 0 Then
 zx(1, 1) = ss + dw2 + (jj - benzu(g) - 1) * (w + dw2) + w / 2 'Left值+w/2
 zx(1, 2) = t + h - rrr - 0.2 * h
 zx(2, 1) = zx(1, 1)
 zx(2, 2) = t + h / 1.2 + dh / 2
 zx(3, 1) = zx(1, 1)
 zx(3, 2) = zx(2, 2)
 zx(4, 1) = zx(3, 1)
 zx(4, 2) = zx(3, 2)
 ActiveSheet.Shapes.AddPolyline(zx).Select
 Selection.ShapeRange.Line.ForeColor.RGB = RGB(50, 0, 128)
 Selection.ShapeRange.Line.Weight = 3
 End If
 Next
 Next
 w = w / 1.2
 h = h / 1.2
 End If
 End If
 Next
 End If
Next
For lv = rmax To 1 Step -1
 Set d(lv) = Nothing
Next
 
For Each p In ActiveSheet.Shapes
 If p.Type <> 8 And p.Type <> 6 And p.Type <> 13 Then p.Select Replace:=False
Next
Response = MsgBox("Y-组合图形 N-转换为图片", vbYesNo)
If Response = vbNo Then
 Selection.CopyPicture xlPicture
 Selection.Delete
 ActiveSheet.Paste Destination:=[G1]
Else
 Selection.ShapeRange.Group
End If
End Sub
Sub DEL()
For Each S In ActiveSheet.Shapes
If S.Type <> 8 Then S.Delete
Next
End Sub