VBA Process Flow Chart using Shapes & Connectors

[zlotowlosapl]

Hi,
I am trying to create process flow chart using shapes and connecting them with straight connectors.
I managed to have shapes created in order I want but I struggle with connectors.
Basically, I would like to connect shapes in the same order the have been created:
Shape 1 with Shape 2, Shape 2 with Shape 3, etc.
I have managed odd connections but that's all...so HELP
Code below and also attached spreadsheet picture:

Sub CreateSpaghettiDiagramShapes()
    Dim ws As Worksheet
    Dim uniqueOps As Collection
    Dim i, j As Long
    Dim colIndex As Long
    Dim op As Variant
    Dim Shape As Shape
    Dim shapeDict As Object
    Dim shp As Object
    
    Set ws = ThisWorkbook.Sheets("Gears") ' Adjust sheet name as necessary
    Set uniqueOps = New Collection
    Set shapeDict = CreateObject("Scripting.Dictionary")
    Set shp = ws.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
    
    ' Collect unique operations
    On Error Resume Next
    For i = 2 To ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
        op = ws.Cells(i, 2).Value
        uniqueOps.Add op, CStr(op)
    Next i
    On Error GoTo 0
    
Dim startshape As Shape
Dim endshape As Shape
Dim ShapesS
Set ShapesS = ws.Shapes

    ' Create diagram with shapes
    colIndex = 5 ' Start at column E
    For i = 1 To uniqueOps.Count
        Set Shape = ws.Shapes.AddShape(msoShapeRectangle, ws.Cells(2, colIndex).Left, ws.Cells(2, colIndex).Top, 100, 50) ' Adjust size as needed
        Shape.TextFrame2.TextRange.Text = uniqueOps(i)
        shapeDict.Add uniqueOps(i), Shape.Name
        colIndex = colIndex + 3 ' Skip a column
        ws.Cells(i + 1, 4).Value = Shape.Name
        
    Next i

    ' Draw arrows between shapes
    For j = 2 To ws.Cells(ws.Rows.Count - 1, 4).End(xlUp).Row
        ' Find start and end shapes for operations
        
      Set startshape = ws.Shapes([ws.range(j, 4).Value])
    Set endshape = ws.Shapes([ws.range(j + 1, 4).Value])
        
     
  'If Not startshape Is Nothing And Not endshape Is Nothing Then
     
    shp.ConnectorFormat.BeginConnect startshape, 3
    shp.ConnectorFormat.EndConnect endshape, 1
'End If
       
        
    Next j
End Sub

Thanks a lot

 

[Sergius]

Hello! Look at this article here on the forum. I think this is what you need.

 

[zlotowlosapl]

Hello! Look at this article here on the forum. I think this is what you need.

Thank you Sergius. I have looked into that code, and unfortunately I am not very fluent in VBA so I am a bit lost. I have changed my code (see bold lines) and i am not getting any errors BUT it is crashing my excel

Sub CreateSpaghettiDiagramShapes()
    Dim ws As Worksheet
    Dim uniqueOps As Collection
    Dim i As Long
    Dim j As Long
    Dim colIndex As Long
    Dim op As Variant
    Dim Shape As Shape
    Dim shapeDict As Object
    Dim shp As Object
    
    Set ws = ThisWorkbook.Sheets("Gears") ' Adjust sheet name as necessary
    Set uniqueOps = New Collection
    Set shapeDict = CreateObject("Scripting.Dictionary")
    Set shp = ws.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
    
    ' Collect unique operations
    On Error Resume Next
    For i = 2 To ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
        op = ws.Cells(i, 2).Value
        uniqueOps.Add op, CStr(op)
    Next i
    On Error GoTo 0
[B]    
Dim startshape As Range
Dim endshape As Range[/B]


    ' Create diagram with shapes
    colIndex = 5 ' Start at column E
    For i = 1 To uniqueOps.Count
        Set Shape = ws.Shapes.AddShape(msoShapeRectangle, ws.Cells(2, colIndex).Left, ws.Cells(2, colIndex).Top, 100, 50) ' Adjust size as needed
        Shape.TextFrame2.TextRange.Text = uniqueOps(i)
        shapeDict.Add uniqueOps(i), Shape.Name
        colIndex = colIndex + 3 ' Skip a column
        ws.Cells(i + 1, 4).Value = Shape.Name
        
    Next i

    ' Draw arrows between shapes
    For j = 2 To ws.Cells(ws.Rows.Count - 1, 4).End(xlUp).Row
        ' Find start and end shapes for operations
        
[B]    Set startshape = ws.Cells(j, 4)[/B]
  [B]   Set endshape = ws.Cells(j + 1, 4)[/B]
        
     
  'If Not startshape Is Nothing And Not endshape Is Nothing Then
     
   [B] shp.ConnectorFormat.BeginConnect ws.Shapes(Trim(Str(startshape))), 3
    shp.ConnectorFormat.EndConnect ws.Shapes(Trim(Str(endshape))), 1[/B]
'End If
 
 
        
        
    Next j
End Sub