如何將Excel中的現有形狀與使用VBA的直線相鏈接

Question

我在工作簿的「工作表1」中有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 

前運行宏：

結果：