如何动态地使用VBA将excel中的现有形状与直线链接

Question

我在工作簿的“sheet1”中有4个圆角矩形，现在我想用它们的形状名称链接它们。形状名称将在另一个工作表的A列中，列中的名称和文本框架中的名称将相同，所以我需要使用VBA代码链接它们，我是VBA的初学者，我是尝试了一些代码，但卡在中间，任何人都可以帮助我解决我的问题。

Sub ConnectingShapes()
Dim ws As Worksheet
Dim txBox As Shape
Dim sTemp As String
On Error Resume Next
Set myDocument = Worksheets(1)
Set s = myDocument.Shapes
i = 2
For Each shp In s.Shapes
'With myDocument.Shapes.AddLine(10, 10, 250, 250).Line
    '.DashStyle = msoLineDashDotDot
    '.ForeColor.RGB = RGB(50, 0, 128)
'End With
'sTemp = shp.Name
txBox = shp.Name
If shp.Name = sTemp Then
Set c = s.AddConnector(msoConnectorCurve, 0, 0, 100, 100)
With c.ConnectorFormat
    .BeginConnect ConnectedShape:=txBox, ConnectionSite:=1
    .EndConnect ConnectedShape:=Cells(i , 9), ConnectionSite:=1
     c.RerouteConnections
End With
i = i + 2
Else
MsgBox ("Nothing Found")
End If`enter code here`
Next
End Sub

Answer 1

这可能是一个很好的起点。您可以在模块中复制它;所有信息都在Sheet1中：

Option Explicit

Sub ConnectingShapes()
    Dim WS As Worksheet
    Set WS = ThisWorkbook.Worksheets(1)

    Dim lastRow As Long
    lastRow = WS.Range("a" & WS.Rows.Count).End(xlUp).Row

    Dim Shp1 As Shape, Shp2 As Shape, Conn As Shape
    Dim i As Long
    Dim rowOffSet As Long: rowOffSet = 1
    For i = 1 To lastRow
        Set Shp1 = GetTxtBoxShapeByContent(WS.Cells(i, 1).Value, WS)
        If i = lastRow Then 'To check if we have to come back to beginning
            rowOffSet = -lastRow + 1
        End If
        Set Shp2 = GetTxtBoxShapeByContent(WS.Cells(i, 1).Offset(rowOffSet, 0).Value, WS)

        Set Conn = WS.Shapes.AddConnector(msoConnectorStraight, 0, 100, 0, 100)
        With Conn.ConnectorFormat
            .BeginConnect Shp1, 1
            .EndConnect Shp2, 1
        End With
        Conn.RerouteConnections
        Set Conn = Nothing
    Next i
End Sub

'Function that gets the wanted txtbox by its content
Function GetTxtBoxShapeByContent(iTxtBoxVal As String, WS As Worksheet) As Shape
    Dim Shp As Shape
    For Each Shp In WS.Shapes
        If Shp.TextFrame.Characters.Text = iTxtBoxVal Then
            Set GetTxtBoxShapeByContent = Shp
            Exit Function
        End If
    Next Shp
End Function

在运行宏之前：

结果：