How to copy and insert shapes with increase in series of text inside of shape ie 1,2,3 or A,B,C by offsetting 2 columns after each increase in series?

[Pramodpandit123]

I need shapes to be copied and increased just like in picture.I tried Using Addshapes but it is not the right way to do it i think.How can i just copy and insert shapes with increase in its series.I tried copy and pasting range but the shapes did not copy.Following is a code i did using Addshapes.Also can anyone tell how to exactly find the Left,top value from {AddShape(msoShapeOval, iLeft, iTop, iWidth, iheight)} or its just Hit and trial ?

Option Explicit

Private Sub Click()


    Dim i, iLeft, iTop, iWidth, iheight As Integer
    Dim c, j As Range
    Set j = Range("A4")
    Set c = Range("D7:D8")
    iLeft = c.Left + (c.Width / 4)
    iTop = c.Top
    iWidth = c.Width / 2
    iheight = c.Height
   
    For i = 1 To j
        
            Dim ovalShape As Shape
            Set ovalShape = Sheet1.Shapes.AddShape(msoShapeOval, iLeft, iTop, iWidth, iheight)
            
            With ovalShape
                ovalShape.ShapeStyle = msoLineStylePreset7
                ovalShape.TextFrame.Characters.Text = i   ' ADD TEXT TO THE SHAPES.
            End With

            iLeft = iLeft + 145
             
        DoEvents
    Next
End Sub

 

[Yongle]

Is this what you want ?
Inputbox 1 asks for the cell to place the first shape (select the cell and click OK)
Inputbox 2 asks how many shapes to add (enter a number and click ok)

Sub AddShapes()
    Dim x As Long, cel As Range, ws As Worksheet, shp As Shape
    Set cel = Application.InputBox("Select cell for first shape and click ok", "INPUTBOX 1", , , , , , 8)
    Set ws = cel.Parent
    
    For x = 1 To Application.InputBox("How many shapes ?", "INPUTBOX 2", 1, , , , , 1)
        Set shp = ws.Shapes.AddShape(msoShapeOval, cel.Left, cel.Top, cel.Width, cel.Width)
        shp.Select
        With Selection.ShapeRange
            .Fill.Visible = msoFalse
            With .TextFrame
                .Characters.Text = x
                .Characters.Font.ColorIndex = 3
                .HorizontalAlignment = xlHAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With .Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Transparency = 0
            End With
        End With
        Set cel = cel.Offset(, 3)
    Next
End Sub

 

[Yongle]

For A, B, C ... (instead of 1,2,3 ..)

.Characters.Text = x

.Characters.Text = Chr(x + 64)

 

[Pramodpandit123]

Wow..This code just surpassed my expectations..Huge Thanks to you!!

 

[Pramodpandit123]

Sir,
I did little bit of edit on code to suit my needs but its not working as i wanted to.
Also instead of selecting cells how can i insert shapes from fixed cell ($A$4).As I am newbie on VBA i could not find a way to work around it.

Option Explicit
Private Sub AddShapes()
    Dim x As Long, cel As Range, ws As Worksheet, shp As Shape, y As Long, z As Long
    y = Range("A4").Value
    z = Range("A5").Value
    Set cel = Application.InputBox("Select cell for first shape and click ok", "INPUTBOX 1", , , , , , 8)
    Set ws = cel.Parent
    
    
    For x = 1 To y
        Set shp = ws.Shapes.AddShape(msoShapeOval, cel.Left, cel.Top, cel.Width, cel.Width)
        shp.Select
        With Selection.ShapeRange
            .Fill.Visible = msoFalse
            With .TextFrame
             .Characters.Text = x
                .Characters.Font.ColorIndex = 3
                .HorizontalAlignment = xlHAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With .Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Transparency = 0
            End With
        End With
        Set cel = cel.Offset(0, 1)
        Next
        
            For x = 1 To z
        Set shp = ws.Shapes.AddShape(msoShapeOval, cel.Left, cel.Top, cel.Width, cel.Width)
        shp.Select
        With Selection.ShapeRange
            .Fill.Visible = msoFalse
            With .TextFrame
             .Characters.Text = Chr(x + 64)
                .Characters.Font.ColorIndex = 3
                .HorizontalAlignment = xlHAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With .Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Transparency = 0
            End With
        End With
        Set cel = cel.Offset(3, 0)
        Next
End Sub

 

[Pramodpandit123]

Fixed cell is $D$6 not $A$4 as A4 is already an input.

 

[Yongle]

It may make life easier if you make row height the same as column width
- I used 90 pixels for both

Private Sub AddShapes()
    Dim x As Long, cel As Range, ws As Worksheet, shp As Shape, y As Long, z As Long
    Set ws = ActiveSheet
    y = ws.Range("A4").Value
    z = ws.Range("A5").Value
'number shapes
    Set cel = Range("D6")
    For x = 1 To y
        Set shp = ws.Shapes.AddShape(msoShapeOval, cel.Left, cel.Top, cel.Width, cel.Width)
        shp.Select
        With Selection.ShapeRange
            .Fill.Visible = msoFalse
            With .TextFrame
             .Characters.Text = x
                .Characters.Font.ColorIndex = 3
                .HorizontalAlignment = xlHAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With .Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Transparency = 0
            End With
        End With
        Set cel = cel.Offset(0, 2)
        Next
'alpha shapes
    Set cel = Range("B7")
            For x = 1 To z
        Set shp = ws.Shapes.AddShape(msoShapeOval, cel.Left, cel.Top, cel.Width, cel.Width)
        shp.Select
        With Selection.ShapeRange
            .Fill.Visible = msoFalse
            With .TextFrame
             .Characters.Text = Chr(x + 64)
                .Characters.Font.ColorIndex = 3
                .HorizontalAlignment = xlHAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With .Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Transparency = 0
            End With
        End With
        Set cel = cel.Offset(2, 0)
        Next
End Sub

 

[Pramodpandit123]

BOOM!!..Exactly what i wanted.THANKS.
1 Last question though.How can i achieve something like in attached picture i.e Draw dotted line over A-A Line or 1-1 Line except for where these 2 grids intersect ie A-1,B-1?Is there any way to achieve this.I could not even spark an idea on how to start it.

 

[Peter_SSs]

Welcome to the MrExcel board!

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: How to copy and insert shapes with increase in series of text inside of shape ie 1,2,
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

 

[Yongle]

Glad it worked for you
Perhaps someone else can answer your last question for you