EXCEL使用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"依据实际更改。

实测图：

Sub test()

    Dim rng As Range

    Dim r, col, n

    Dim brr()

    With ActiveSheet

        Set rng = .Range("B2：L100") '把这里改成你实际对应的区域

        r = rng.Cells(1, 1).Row: col = rng.Cells(1, 1).Column

        arr = .[b2].CurrentRegion

        ReDim brr(1 To UBound(arr, 1) * UBound(arr, 2), 1 To 2)

        n = 1

        For i = LBound(arr, 1) To UBound(arr, 1)

            For j = LBound(arr, 2) To UBound(arr, 2)

                With .Cells(i + r - 1, j + col - 1)

                    If .Value <> "" Then

                        brr(n, 1) = .Left + .Width * 0.5

                        brr(n, 2) = .Top + .Height * 0.5

                        n = n + 1

                    End If

                End With

            Next

        Next

        If n > 2 Then

            With .Shapes.BuildFreeform(msoEditingAuto, brr(1, 1), brr(1, 2))

                For i = 2 To n - 1

                    .AddNodes msoSegmentLine, msoSegmentLine, brr(i, 1), brr(i, 2)

                    m = m + 1

                Next

            .ConvertToShape

            End With

        End If

    End With

End Sub

百度排版真烂。。

这个只能通过VBA来实现。VBA实现这类问题比较依赖工作表的结构。见附件。代码如下：

Sub myLine()

    Dim i As Integer, rCount As Integer, cCount As Integer

    Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single, w As Single, h As Single

    Dim s As Shape

    Dim lineColor

    

    For Each s In ActiveSheet.Shapes

        If s.Type = msoLine Then s.Delete

    Next s

    

    ActiveSheet.AutoFilterMode = False

    

    lineColor = Range("M1").Interior.Color

    

    With Cells(1, 1).CurrentRegion

        .Rows.Hidden = False

        .Columns.Hidden = False

        rCount = .Rows.Count

        cCount = .Columns.Count

    End With

    

    For i = 2 To rCount - 1

        With Range(Cells(i, 1), Cells(i, cCount)).SpecialCells(xlCellTypeConstants).Cells(1, 1)

            w = .Width

            h = .Height

            x1 = .Left + w / 2

            y1 = .Top + h / 2

        End With

        With Range(Cells(i + 1, 1), Cells(i + 1, cCount)).SpecialCells(xlCellTypeConstants).Cells(1, 1)

            w = .Width

            h = .Height

            x2 = .Left + w / 2

            y2 = .Top + h / 2

        End With

        With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Line

            .DashStyle = msoLineSolid

            .Weight = 1.25

            .ForeColor.RGB = lineColor

        End With

    Next i

End Sub

---