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