Putting shape at InputBox Value

Question

I want to make a Macro-Button, when you press it, a InputBox pops up and you can choose a cell. At that cell a shape should be placed. I have the following code:

Sub TrialwithDate()


Dim rng As Range
Dim clLeft As Double
Dim clTop As Double
Dim clHeight As Double
Dim clWidth As Double


Set rng = Application.InputBox("Choose starting point", Type:=8)



Set cl = Range(rng)

clLeft = cl.Left
clTop = cl.Top
clHeight = cl.Height
clWidth = cl.Width

Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, clLeft, clTop, Range("K36").Value * 80, 37)

With shp
    .TextFrame2.TextRange.Text = "Test"
    .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    .TextFrame2.TextRange.Font.Size = 11
    
    .Fill.ForeColor.RGB = RGB(146, 208, 80)
    .TextFrame.HorizontalAlignment = xlHAlignCenter
    .TextFrame.VerticalAlignment = xlVAlignCenter
End With


End Sub

What else I am working on for this macro. After this shape is placed, 3 more shapes should be created which start at the end of the previous shape.

For example:

The cell i choose is F5. The first shape starts there. The shape has a length which is exactly calculated and in the next ROW, the next shape should start at the end of the first one. So shape goes from F5 to J10, the next shape starts J11, and so on.

Any help is much much appreciated, cause i started VBA two weeks ago

Answer 1

Get it done with a For loop.

With shp
    .TextFrame2.TextRange.Text = "Test"
    .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    .TextFrame2.TextRange.Font.Size = 11
    
    .Fill.ForeColor.RGB = RGB(146, 208, 80)
    .TextFrame.HorizontalAlignment = xlHAlignCenter
    .TextFrame.VerticalAlignment = xlVAlignCenter
    
    .Copy
    Dim i As Integer
    For i = 1 To 3
        Cells(cl.Row + 6 * i, cl.Column + 5 * i).Select
        ActiveSheet.Paste
    Next
End With

Answer 2

Please, test the next adapted code. It calculates the range to give Height and Width to the rectangle, for each next position:

Sub TrialwithDate()

 Dim rng As Range, Cl As Range, shp As Shape, i As Long

 Set rng = Application.InputBox("Choose starting point", Type:=8)
 Const rowsDown As Long = 5

 Set Cl = rng
 For i = 1 To 3
    Set Cl = Range(Cl, Cl.Offset(rowsDown, 4)) 'the range to give Height and Width...
    
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Cl.left, Cl.top, Cl.width, Cl.height)
    
    With shp
        .TextFrame2.TextRange.text = "Test"
        .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
        .TextFrame2.TextRange.Font.size = 11
        
        .Fill.ForeColor.RGB = RGB(146, 208, 80)
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .TextFrame.VerticalAlignment = xlVAlignCenter
    End With
    Set Cl = Cl.cells(1).Offset(rowsDown + 1) 'reinitialize the range for its next starting cell
 Next i

End Sub