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

问题描述：

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

i've 4 rounded rectangular shapes in "sheet1" of a workbook, now i want to link them with their shape names. The shape names will be in column A of another sheet, the names in the column and the names in the text frame of shape will be same, so i need to link them using VBA code, i am a beginner in VBA, i've tried some code but stuck in between, can anyone help me out to solve my problem.

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

答

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

This may be a good starting point. You can copy this in a module; all info are in 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

运行宏之前：

Before running the macro:

结果：

Result:

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

相关推荐