Créer plusieurs shapes simultanément

Bonjour,

je souhaiterais dès lors qu'un bouton est cliqué créer des rectangles aux paramètres spécifiques.

J'ai réussi à faire cela mais je souhaiterais AUSSI qu'Excel ne me créé non pas un seul rectangle avec ces propriétés mais plutôt un nombre déterminé par l'utilisateur dans la "Textbox51"

Je précise bien que si Textbox51 a été renseigné à "4" par l'utilisateur alors je souhaite avoir 4 rectangles avec ces mêmes propriétés.

Voici le code que j'ai et qui fonctionne pour créer "1" rectangle

PS : je sais ... j'essaye même si je n'y connais pas grand chose...

D'avance merci !!

Private Sub CommandButton2_Click()

Dim Hauteur As Variant
Dim LT1 As Variant
Dim Couleur As Variant
Couleur = 2
CoordX = 1
CoordY = 1
Hauteur = 16
LT1 = Application.CentimetersToPoints(TextBox81) / 10

Application.ScreenUpdating = True

Sheets("User").Select
Range("A1").Select

    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 10, 100, LT1, Hauteur).Select

        Selection.Text = "Textebzjjjjfjf"
        Selection.Font.ColorIndex = Automatic
        Selection.Font.Name = "Calibri"
        Selection.Font.FontStyle = "Normal"
        Selection.Font.Size = 6
        Selection.ShapeRange.Fill.ForeColor.SchemeColor = 4              
        Selection.ShapeRange.Line.Visible = False                       

    End With
End Sub

bonjour, un premier essai

Private Sub CommandButton2_Click()

     Dim Hauteur As Variant
     Dim LT1   As Variant
     Dim Couleur As Variant
     Couleur = 2
     CoordX = 1
     CoordY = 1
     Hauteur = 16
     LT1 = Application.CentimetersToPoints(TextBox81) / 10

     Application.ScreenUpdating = True
     Set sh = ActiveSheet
     nmb = Application.InputBox("nombre de rectangles")
     If IsNumeric(nmb) Then
          For i = 1 To nmb
               DoEvents
               Set shp = sh.Shapes.AddShape(msoShapeRectangle, 10, 100, 100, 100)
               With shp
                    DoEvents
                    With .TextFrame2.TextRange
                         .Characters.Text = "Textebzjjjjfjf" & i
                         .Font.Name = "Calibri"
                         .Font.Size = 6
                    End With
                    .Fill.ForeColor.SchemeColor = 4
                    .Line.Visible = False
                    .Left = sh.Cells(i * 5, i * 5).Left 'gauche = gauche de la cellule( i*5,i*5)
                    .Top = sh.Cells(i * 5, i * 5).Top
               End With
               DoEvents
          Next
     End If
End Sub

Bonjour

Merci ! ca m'a avancé, j'ai un peu rebricolé mais on avance juste comme je n'y connais rien 2 petites amélioration si vous avez svp :

concernant le texte, je ne comprends pas ca ne créé pas en taille de police "6" alors pourquoi ? et je voudrais aligner le texte hoizontalement à gauche et verticalement centré (un jeu d'enfant pour vous je suppose)

A l'avance merci

Private Sub CommandButton2_Click()

Dim Hauteur As Variant
Dim LT1 As Variant

Dim Couleur As Variant

Couleur = 2

CoordX = 1
CoordY = 1
Hauteur = 16
LT1 = Application.CentimetersToPoints(TextBox81) / 10

Application.ScreenUpdating = True

Set sh = ActiveSheet
     nmb = TextBox51.Value
     If IsNumeric(nmb) Then
          For i = 1 To nmb
               DoEvents
               Set shp = sh.Shapes.AddShape(msoShapeRectangle, 10, 100, LT1, Hauteur)
               With shp
                    DoEvents
                    With .TextFrame2.TextRange
                         .Characters.Text = "Blabla" & i
                         .Font.Name = "Calibri"
                         .Font.Size = 8

                    End With
                    .Fill.ForeColor.SchemeColor = 4
                    .Line.Visible = False

               End With

               DoEvents
          Next
     End If

Je voulais dire en taille 8 désolé, en fait peu importe le chiffre que je mets ca ne change pas la taille du texte contenu dans le shape

Private Sub CommandButton2_Click()

     Dim Hauteur As Variant
     Dim LT1   As Variant
     Dim Couleur As Variant
     Couleur = 2
     CoordX = 1
     CoordY = 1
     Hauteur = 16
     LT1 = Application.CentimetersToPoints(TextBox81) / 10

     Application.ScreenUpdating = True
     Set sh = ActiveSheet
     nmb = Application.InputBox("nombre de rectangles")
     If IsNumeric(nmb) Then
          For i = 1 To nmb
               DoEvents
               Set shp = sh.Shapes.AddShape(msoShapeRectangle, 10, 100, 400, 100)

               With shp.TextFrame.Characters
                    .Font.Bold = True
                    .Text = "Textebzjjjjfjf" & vbLf & "2ième ligne" & vbLf & "x= " & i
                    .Font.Name = IIf(i Mod 2, "Calibri", "courier new")
                    .Font.Size = WorksheetFunction.RandBetween(5, 10) * 3
                    .Font.Color = RGB(255, 0, 0)
               End With

               With shp.TextFrame
                    .HorizontalAlignment = xlHAlignLeft
                    .VerticalAlignment = xlVAlignCenter
               End With

               shp.Left = sh.Cells(i * 5, i * 5).Left     'gauche = gauche de la cellule( i*5,i*5)
               shp.Top = sh.Cells(i * 5, i * 5).Top
               DoEvents
          Next
     End If
End Sub

https://software-solutions-online.com/textframe-object-vba/

Merci !!!