Create shapes and groups automatically with distances

[Omer_K]

Hey friends,
I would be happy for your help
I want to create the following image:
3 (fixed) groups of shapes,
When in cell G1 when I enter the number of shapes in the group - the image will show the number of shapes in each group
The first example has 2 shapes in each group,
In the second example there are 3 shapes in each group
In cell G2 there will be the distance between each group and group
The G3cell will have the distance between each shape and form in each group

Hope I was clear

Example 1:

Example 2:

 

[Colo]

Hello there,
Regarding the style of shapes, you can amend the code.
Hope my understanding is correct.

Sub Sample1()
'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 dLeft As Double = 5    'left of the first shape
    Const dTop As Double = 300    'top of the first shape
    Const dWidth As Double = 30    'width of the shapes
    Const dHeight As Double = 50    'height of the shapes
    Dim i As Long, j As Long, x1 As Double, x2 As Double
    Dim shpGrp() As String
    For i = 1 To 3
        ReDim shpGrp(1 To nos)
        For j = 1 To nos
            With ActiveSheet.Shapes.AddShape(msoShapeCan, dLeft + x1 + x2, dTop, dWidth, dHeight)
                shpGrp(j) = .Name
                x1 = x1 + .Width + dbs 'Distance between shapes
            End With
        Next
        With ActiveSheet.Shapes.Range(shpGrp)
            .Group
            x2 = x2 + .Width + sbg 'Space between groups
            x1 = 0    'reset
        End With
    Next
End Sub

 

[Colo]

Here's an example of how to change the styles of shapes.

Sub MakeShapes(nos, sbg, dbs)
    Const dLeft As Double = 5    'left of the first shape
    Const dTop As Double = 300    'top of the first shape
    Const dWidth As Double = 30    'width of the shapes
    Const dHeight As Double = 50    'height of the shapes
    Dim i As Long, j As Long, x1 As Double, x2 As Double
    Dim shpGrp() As String
    For i = 1 To 3
        ReDim shpGrp(1 To nos)
        For j = 1 To nos
            With ActiveSheet.Shapes.AddShape(msoShapeFlowchartMagneticDisk, dLeft + x1 + x2, dTop, dWidth, dHeight)
                'STYLES OF SHAPE
                '------------------------------
                .Fill.Visible = msoFalse
                With .Line
                    .Visible = msoTrue
                    .Weight = 2.5
                End With
                '------------------------------
                shpGrp(j) = .Name
                x1 = x1 + .Width + dbs    'Distance between shapes
            End With
        Next
        With ActiveSheet.Shapes.Range(shpGrp)
            .Group
            x2 = x2 + .Width + sbg    'Space between groups
            x1 = 0    'reset
        End With
    Next
End Sub

 

[Omer_K]

Thank you Colo
When I try to run the VBA
I get a runtime13 error message
And emphasizes to me that the wrong line is:
x2 = x2 + .Width + sbg 'Space between groups
any Ideas?

 

[Omer_K]

It works great !!
Thank you very much Colo
small question..
Is it possible to add text boxes within the group below that will show the distance between the shapes
And up between group to group a text box with the distance between the groups?

 

[Colo]

Adding text boxes? It's easy to add but the setting position of them needs to be calculated and tweaked. Also, I added arrows between shapes. if you don't need them, you can comment them out. (Adding a connector (arrows) is a little tricky way to set their position because Excel moves it automatically.) Anyway please give this a try.

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

 

[Omer_K]

Thank you so much Colo - It works Perfect

 

[Omer_K]

Adding text boxes? It's easy to add but the setting position of them needs to be calculated and tweaked. Also, I added arrows between shapes. if you don't need them, you can comment them out. (Adding a connector (arrows) is a little tricky way to set their position because Excel moves it automatically.) Anyway please give this a try.

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

Hey Colo
How can I change the color of the text in TextBox or the color of the outline?
Thank you