Sub MiseEnforme_Rack_Plan_G_SIXTO()
Dim s As Shape, Shp As Shape, i&, arrSh(100), col
raz
Set F = ActiveSheet: X = 300: Y = 20: L = 32: H = 10
col = Array(11851260, vbMagenta, 12566463, vbBlue, vbGreen, vbYellow, 9944516) 'tableau des couleurs
For i = 2 To F.Cells(Rows.Count, 1).End(xlUp).Row
rack = F.Cells(i, 1)
For j = 1 To Val(F.Cells(i, 2))
xCol = CLng(col(i - 2))
Set s = Forme(msoShapeRectangle, 300, 20, , , , xCol)
s.Left = X + L * (j - 1): s.Top = Y + (15 * (i - 2))
s.TextFrame.Characters.Text = rack & j: s.Name = rack & j
k = k + 1: arrSh(k) = s.Name
Next j
If j > 2 Then
F.Shapes.Range(arrSh).Group.Name = "Rangée_" & rack: Erase arrSh
End If
Next i
End Sub
Function Forme(atSh As MsoAutoShapeType, X, Y, Optional H = 32, Optional L = 10, Optional cLi = vbBlue, Optional cFi = vbWhite) As Shape
Set Forme = ActiveSheet.Shapes.AddShape(atSh, X, Y, H, L)
Forme.Line.Weight = 1.5: Forme.Line.ForeColor.RGB = cLi: Forme.Fill.ForeColor.RGB = cFi
Forme.TextFrame.Characters.Font.Size = 7: Forme.TextFrame.Characters.Font.Color = vbBlack
Forme.TextFrame2.VerticalAnchor = 3: Forme.TextFrame2.TextRange.ParagraphFormat.Alignment = 2
End Function
Sub raz()
Dim v& 'On vide l'existant
For v = ActiveSheet.Shapes.Count To 1 Step -1
ActiveSheet.Shapes(v).Delete
Next v
End Sub