Sub MyTest()
MyCon [B2:B3], [E3], 10, 1
MyCon [B2], [E6], 10, 2
MyCon [B2], [E7], 10, 3
MyCon [B6], [E2], 4, 4
MyCon [B6], [E8], 4, 5
End Sub
Function MyCon(Rng1 As Range, Rng2 As Range, Optional Color As Integer, Optional x As Double)
Dim MyShape As Shape, n1$, n2$, n3$
Dim L, T, W, H
If IsEmpty(x) Then x = 0
If IsEmpty(Color) Then Color = 10 'red
'Draw rounded rectangle object around Rng1
With Rng1
L = .Left
T = .Top
W = .Width
H = .Height
End With
Set MyShape = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, L, T, W, H)
n1$ = Chr(164) & Rng1.Address(False, False) & ":" & x
With MyShape
.Name = n1$
End With
Set Shape2 = ActiveSheet.Shapes(n1$)
With Shape2
.Fill.Visible = False
.Line.ForeColor.SchemeColor = Color
End With
'Draw rounded rectangle object around Rng2
With Rng2
L = .Left
T = .Top
W = .Width
H = .Height
End With
Set MyShape = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, L, T, W, H)
n2$ = Chr(164) & Rng2.Address(False, False) & ":" & x
With MyShape
.Name = n2$
End With
Set Shape2 = ActiveSheet.Shapes(n2$)
With Shape2
.Fill.Visible = False
.Line.ForeColor.SchemeColor = Color
End With
'connect the shapes with a line
Set MyShape = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, L, T, W, H)
n3$ = n1$ & "-" & n2$
With MyShape
.Name = n3$
.Line.ForeColor.SchemeColor = Color
.Line.DashStyle = msoLineDash
.ConnectorFormat.BeginConnect ActiveSheet.Shapes(n1$), 4
.ConnectorFormat.EndConnect ActiveSheet.Shapes(n2), 2
End With
End Function
'You can use this macro to delete all the MyCon shape objects.
Sub MyCon_Clear()
For Each sh In ActiveSheet.Shapes
If Left(sh.Name, 1) = Chr(164) Then sh.Delete
Next sh
End Sub
The variable inputs for the MyCon function are pretty simple.