EXCEL使用VBA代码自动画箭头连线？
表格AC列选择内容，会在前面对应单元格内自动显示对应的图形，图形显示后，如何通过VBA自动在上一行图形和本行图形之间通过直线箭头连接？请参考附图。
Sub ConnectSymbol()
Dim rangeIN As Range
Dim cellPrev As Range
Dim cellNext As Range
Dim cell As Range
Dim i As Integer
Dim arrRange() As Range
Dim Position As String
Dim shp As Shape
Set rangeIN =Sheets("Sheet1").Range("D3:P14")
For Each shp In Sheets("Sheet1").Shapes
If shp.Connector Then shp.Delete
Next shp
ReDim arrRange(0)
For Each cell In rangeIN
If cell.Value <> "" Then
ReDim Preserve arrRange(i)
Set arrRange(i) = cell.MergeArea
i = i + 1
End If
Next cell
For i = LBound(arrRange) To UBound(arrRange) - 1
Set cellPrev = arrRange(i)
Set cellNext = arrRange(i + 1)
If cellNext.Column > cellPrev.Column Then
Position = "R"
ElseIf cellNext.Column < cellPrev.Column Then
Position = "L"
Else
Position = "B"
End If
Call DrawArrows(cellPrev, cellNext, Position)
Position = ""
Next i
MsgBox "Complete", vbInformation, "Tips"
End Sub
Private Sub DrawArrows(FromRange As Range, ToRange As Range, Relative As String)
Dim dleft1 As Double, dleft2 As Double
Dim dtop1 As Double, dtop2 As Double
Dim dheight1 As Double, dheight2 As Double
Dim dwidth1 As Double, dwidth2 As Double
dleft1 = FromRange.Left
dleft2 = ToRange.Left
dtop1 = FromRange.Top
dtop2 = ToRange.Top
dheight1 = FromRange.Height
dheight2 = ToRange.Height
dwidth1 = FromRange.Width
dwidth2 = ToRange.Width
Select Case Relative
Case "R"
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, dleft1 + dwidth1 * 2 / 3, dtop1 + dheight1 * 2 / 3, dleft2 + dwidth2 / 3, dtop2 + dheight2 / 3).Select
Case "L"
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, dleft1 + dwidth1 / 3, dtop1 + dheight1 * 2 / 3, dleft2 + dwidth2 * 2 / 3, dtop2 + dheight2 / 3).Select
Case "B"
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, dleft1 + dwidth1 / 2, dtop1 + dheight1 * 2 / 3, dleft2 + dwidth2 / 2, dtop2 + dheight2 / 3).Select
End Select
With Selection.ShapeRange.Line
.EndArrowheadStyle = msoArrowheadTriangle
.Weight = 1
.ForeColor.RGB = RGB(0, 0, 0)
End With
End Sub
运行ConnectSymbol过程即可。代码中的"Sheet1"、"D3:P14"依据实际更改。
实测图：
