Option Explicit
Sub Sample2()
'Apply this procedure to a command button
'nos: Number of shapes in group
'sbg: Space between groups
'dbs: Distance between shapes
Dim nos: nos = Range("G1").Value
Dim sbg: sbg = Range("G2").Value
Dim dbs: dbs = Range("G3").Value
Call MakeShapes(nos, sbg, dbs)
End Sub
Sub MakeShapes(nos, sbg, dbs)
Const sLeftPos As Single = 5 'left of the first shape
Const sTopPos As Single = 300 'top of the first shape
Const sWidth As Single = 30 'width of the shapes
Const sHeight As Single = 50 'height of the shapes
Const sTxtW As Single = 90
Const sTxtH As Single = 30
Dim i As Long, j As Long, x1 As Single, x2 As Single
Dim shpGrp() As String, shp() As Object, grp(1 To 3) As Object, ShapeCon As Object
For i = 1 To 3
ReDim shpGrp(1 To nos * 2)
ReDim shp(1 To nos)
x1 = sLeftPos
For j = 1 To nos
'INFO:AddShape (Type, Left, Top, Width, Height)
Set shp(j) = ActiveSheet.Shapes.AddShape(msoShapeFlowchartMagneticDisk, sLeftPos + x1 + x2, sTopPos, sWidth, sHeight)
With shp(j)
'STYLES OF SHAPE
.Fill.Visible = msoFalse
With .Line
.Visible = msoTrue
.Weight = 1
End With
shpGrp(j) = .Name 'Add as a group member
x1 = x1 + .Width + dbs 'Distance between shapes
End With
Next
'Add Red Arrows between shapes
'If this function is not necessary just comment them out.
For j = 1 To nos - 1
'Add Connectors
Set ShapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
'Connector Reroute Connection
With ShapeCon
.ConnectorFormat.BeginConnect shp(j), 1
.ConnectorFormat.EndConnect shp(j + 1), 1
.RerouteConnections
.IncrementTop 15 'Tweaking position of the arrow after RerouteConnections
With .Line
.BeginArrowheadStyle = msoArrowheadTriangle
.EndArrowheadStyle = msoArrowheadTriangle
.Visible = msoTrue
.Weight = 1.5
.ForeColor.RGB = RGB(255, 0, 0) 'RED
End With
End With
shpGrp(j + nos) = ShapeCon.Name 'Add as a group member
Next
Set grp(i) = ActiveSheet.Shapes.Range(shpGrp).Group
x2 = x2 + grp(i).Width + sbg 'Space between groups
x1 = 0 'reset
'Add TextBoxes for Distance Between shapes
With grp(i)
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, (.Left + (.Width - sTxtW) / 2), .Top + .Height + 15, sTxtW, sTxtH)
.Fill.Visible = msoFalse
With .TextFrame2.TextRange.Characters
.Text = "Distance Between" & vbCrLf & "shape " & dbs
.ParagraphFormat.Alignment = msoAlignCenter
With .Font
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.NameComplexScript = "Arial"
.Size = 8
End With
End With
With .Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
End With
End With
End With
Next
For j = 1 To 2
'Add Blue Arrows between groups
'If this function is not necessary just comment them out.
'Add Connectors
Set ShapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
'Connector Reroute Connection
With ShapeCon
.ConnectorFormat.BeginConnect grp(j).GroupItems(nos), 1
.ConnectorFormat.EndConnect grp(j + 1).GroupItems(1), 1
.RerouteConnections
.IncrementTop -15 'Tweaking position of the arrow after RerouteConnections
.ScaleWidth 0.78, msoFalse, msoScaleFromMiddle 'Tweaking Width of the RED arrow
With .Line
.BeginArrowheadStyle = msoArrowheadTriangle
.EndArrowheadStyle = msoArrowheadTriangle
.Visible = msoTrue
.Weight = 1.5
.ForeColor.RGB = RGB(112, 48, 160) 'BLUE
End With
End With
'Add TextBoxes for Between Groups
With grp(j)
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, .Left + ((.Width * 2 + sbg) - sTxtW) / 2, .Top - 40, sTxtW, sTxtH)
.Fill.Visible = msoFalse
With .TextFrame2.TextRange.Characters
.Text = "Space Between" & vbCrLf & "groups " & sbg
.ParagraphFormat.Alignment = msoAlignCenter
With .Font
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.NameComplexScript = "Arial"
.Size = 8
End With
End With
With .Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
End With
End With
End With
Next
End Sub