Sub MiseEnformerack_Plan_G()
ThisWorkbook.RefreshAll
'On dessine un carré pour une travée par rangée
'variable
Dim sh As Shape
Dim i As Integer, NbRangee As Integer, nbtravee As Integer, Coorx As Integer, Coory As Integer
Dim n As Integer
n = 0
NbRangee = Feuil6.Range("C2").Value 'nb de rangée
'Zone de traçage
ThisWorkbook.Worksheets("Plan_G").Activate
' Pas de grille de fond
ActiveWindow.DisplayGridlines = False
' On vide l'existant
' À vider
For i = ActiveSheet.Shapes().Count To 1 Step -1
ActiveSheet.Shapes(i).Delete
Next i
' Valeurs de départ
Coorx = 300
Coory = 20
For nbligne = 1 To NbRangee
ligne = nbligne + 1
nbtravee = Cells(ligne, 2).Value
n = n + 1
For t = 1 To nbtravee
Set sh = ActiveSheet.Shapes(). _
AddShape(msoShapeRectangle, Coorx, Coory, 32, 10)
' Mise en forme
sh.Line.Weight = 1.5
sh.Line.ForeColor.RGB = RGB(30, 144, 255)
sh.Fill.ForeColor.RGB = RGB(255, 255, 255)
sh.Name = Cells(ligne, 1) & t
With sh.TextFrame.Characters
.Font.Color = vbBlack
.Font.Size = 7
.Text = Cells(ligne, 1) & t
End With
'Alignement du texte dans les case
'Sélection de la rangée
For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell, Range("$D$1:$AD$40")) Is Nothing Then
s.Select False
End If
Next s
'Centrage du texte dans les cases
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignCenter
' Grouper les Shapes par rangée
Dim tab_SHP() As Variant, v&, shp As Shape
With ActiveSheet
ReDim tab_SHP(1 To .Shapes.Count)
For v = 1 To .Shapes.Count
If .Shapes(v).AutoShapeType = 1 Then ' 1=Rectangle
tab_SHP(v) = .Shapes(v).Name
End If
Next
Set shp = .Shapes.Range(tab_SHP).Group
End With
shp.Name = "Rangee" & n
' Position suivante
Coorx = Coorx + 32
If t = nbtravee Then
Coorx = 300
Coory = Coory + 15
End If
Next t
Next nbligne
Range("A2").Select
MsgBox "Le plan général a été crée !"
End Sub