Reputation: 11
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
Upvotes: 1
Views: 4693
Reputation: 1622
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:
Upvotes: 3