Sub DrawNetworkDiagram() Dim ws As Worksheet Dim lastRow As Long, i As Long, j As Long Dim ActivityLevels As Object, LevelRows As Object, nodePos As Object Dim startX As Single, startY As Single Dim ColGap As Single, RowGap As Single Dim activity As String, Predecessors As String, Duration As String Dim level As Long, rowInLevel As Long Dim srcActivity As String, destActivity As String Dim srcRight As Single, srcCenterY As
Single Dim destLeft As Single, destCenterY As Single Set ws = ThisWorkbook.Sheets("Sheet1") Set ActivityLevels = CreateObject("Scripting.Dictionary") Set LevelRows = CreateObject("Scripting.Dictionary") Set nodePos = CreateObject("Scripting.Dictionary") ' 清空原有图形 On Error Resume Next ws.Shapes.SelectAll Selection.Delete On Error GoTo 0 ' 初始化布局参数 startX = 50 startY = 50 ColGap = 100 RowGap = 60 ' 读取活动数据 lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' 第一步：计算所有活动的层级 For i = 2 To lastRow activity = ws.Cells(i, 1).Value Predecessors = ws.Cells(i, 4).Value If Predecessors = "-" Then ActivityLevels(activity) = 0 Else Dim arrPre() As String arrPre = Split(Replace(Predecessors, " ", ""), ",") Dim maxLevel As Integer maxLevel = 0 For j = LBound(arrPre) To UBound(arrPre) If ActivityLevels.Exists(arrPre(j)) Then If ActivityLevels(arrPre(j)) > maxLevel Then maxLevel = ActivityLevels(arrPre(j)) End If End If Next j ActivityLevels(activity) = maxLevel + 1 End If Next i ' 第二步：绘制节点并存储边界坐标 For i = 2 To lastRow activity = ws.Cells(i, 1).Value Predecessors = ws.Cells(i, 4).Value level = ActivityLevels(activity) ' 确定同一层级中的行位置 If Not LevelRows.Exists(level) Then LevelRows(level) = 0 Else LevelRows(level) = LevelRows(level) + 1 End If rowInLevel = LevelRows(level) '绘制节点并存储四角坐标 With ws.Shapes.AddShape(msoShapeRectangle, _ startX + level * ColGap, _ startY + rowInLevel * RowGap, _ 50, 25) .name = "Node_" & activity With .TextFrame .HorizontalAlignment = xlHAlignCenter .VerticalAlignment = xlVAlignCenter .Characters.Text = activity With .Characters.Font .Size = 10 .name = "Arial" End With End With .Fill.ForeColor.RGB = RGB(200, 220, 255) nodePos(activity) = Array(.Left, .Top, .Left + .Width, .Top + .Height) End With Next i ' 第三步：绘制箭头和标签（优化标签位置算法） For i = 2 To lastRow destActivity = ws.Cells(i, 1).Value Predecessors = ws.Cells(i, 4).Value Duration = ws.Cells(i, 3).Value & "d If Predecessors <> "-" Then Dim arrPredecessors As Variant arrPredecessors = Split(Replace(Predecessors, " ", ""), ",") For j = LBound(arrPredecessors) To UBound(arrPredecessors) srcActivity = arrPredecessors(j) If nodePos.Exists(srcActivity) And nodePos.Exists(destActivity) Then ' 计算箭头端点坐标 srcRight = nodePos(srcActivity)(2) srcCenterY = (nodePos(srcActivity)(1) + nodePos(srcActivity)(3)) / 2 destLeft = nodePos(destActivity)(0) destCenterY = (nodePos(destActivity)(1) + nodePos(destActivity)(3)) / 2 ' 绘制箭头 With ws.Shapes.AddConnector(msoConnectorStraight, _ srcRight, srcCenterY, destLeft, destCenterY) .Line.EndArrowheadStyle = msoArrowheadTriangle .Line.Weight = 1 End With ' 计算标签位置 Dim midX As Single, midY As Single Dim angle As Double, labelOffset As Single midX = (srcRight + destLeft) / 2 midY = (srcCenterY + destCenterY) / 2 labelOffset = 5 ' 垂直偏移量 ' 计算连线角度（弧度） angle = WorksheetFunction.Atan2(destCenterY - srcCenterY, destLeft - srcRight) ' 计算垂直上方偏移坐标 Dim labelX As Single, labelY As Single labelX = midX + labelOffset * Cos(angle + 1.5708) ' +90度偏移 labelY = midY + labelOffset * Sin(angle + 1.5708) - 10 ' 调整标签位置确保在连线上方 If destCenterY < srcCenterY Then ' 处理向上箭头 labelY = labelY - 2 * labelOffset End If ' 添加紧凑标签 With ws.Shapes.AddTextbox(msoTextOrientationHorizontal, _ labelX - 10, labelY - 8, 20, 16) .TextFrame.Characters.Text = Duration .TextFrame.Characters.Font.Size = 7 .Fill.ForeColor.RGB = RGB(255, 255, 230) ' 浅黄背景 .Line.Visible = msoFalse .ZOrder msoBringToFront End With End If Next j End If Next i ' 第四步：标注关键路径（保持红色粗线） HighlightCriticalPath nodePosEnd Sub
Private Sub HighlightCriticalPath(ByRef nodePos As Object) Dim CriticalPath As Variant CriticalPath = Array("A", "B", "C", "X", "E", "F", "G", "H") Dim i As Long For i = 0 To UBound(CriticalPath) - 1 If nodePos.Exists(CriticalPath(i)) And nodePos.Exists(CriticalPath(i + 1)) Then ' 获取关键路径端点坐标 Dim srcRight As Single, srcCenterY As Single srcRight = nodePos(CriticalPath(i))(2) srcCenterY = (nodePos(CriticalPath(i))(1) + nodePos(CriticalPath(i))(3)) / 2 Dim destLeft As Single, destCenterY As Single destLeft = nodePos(CriticalPath(i + 1))(0) destCenterY = (nodePos(CriticalPath(i + 1))(1) + nodePos(CriticalPath(i + 1))(3)) / 2 ' 绘制关键路径 With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _ srcRight, srcCenterY, destLeft, destCenterY) .Line.ForeColor.RGB = RGB(255, 0, 0) .Line.Weight = 2 .ZOrder msoSendToBack End With End If Next iEnd Sub
