Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not Sh.Name Like "Groupe*" Then Exit Sub
Dim zone As Range, lig&, x#, y#, s As Shape
Set F = Feuil1 'CodeName
Set zone = Sh.[B3:E27] 'zone des Shapes, à adapter
lig = Val(Mid(Sh.Name, 7)) + 2
Application.ScreenUpdating = False
'---RAZ---
For Each s In Sh.Shapes
If Not Intersect(s.TopLeftCell, zone) Is Nothing _
And s.Name <> "Rectangle 1" Then s.Delete
Next
'---initialisation---
With Sh.Shapes("Rectangle 1")
.Left = zone(1).Left + 0.1
.Top = zone(1).Top + 0.1
.Width = zone.Width - 0.2
.Height = zone.Height - 0.2
.Visible = False
End With
x = zone(1).Left + 16
y = zone(1).Top + 16
'---Copies des Shapes à adapter---
CopieShape F.[L4:N4], lig, F.Shapes("Picture 66"), x, y, "Réhausse", F.[S7], 0
CopieShape F.[K4], lig, F.Shapes("Picture 63"), x, y, "Dalle", F.[S9], 0
CopieShape F.[F4:J4], lig, F.Shapes("Picture 67"), x, y, "TR", F.[S13], 0
CopieShape F.[C4:E4], lig, F.Shapes("Picture 64"), x, y, "ED", F.[S18], 0
If y > zone(1).Top + 16 Then
CopieShape F.[B4], lig, F.Shapes("Picture 65"), x, y, "FDR ht", F.[S24], 1
Sh.Shapes("Rectangle 1").Visible = True
If y > zone(1).Top + zone.Height - 16 Then
'---ajustement de la hauteur du groupe à la zone des Shapes---
For Each s In Sh.Shapes
If Not Intersect(s.TopLeftCell, zone) Is Nothing Then s.Select False
Next
With Selection.ShapeRange.Group 'groupage
.Height = zone.Height - 0.2
.Ungroup
End With
Else
'---positionnement des shapes en bas de zone---
For Each s In Sh.Shapes
If Not Intersect(s.TopLeftCell, zone) Is Nothing _
And s.Name <> "Rectangle 1" Then s.Select False
Next
With Selection.ShapeRange.Group 'groupage
.Top = zone(1).Top + zone.Height - .Height - 16
.Ungroup
End With
End If
ActiveCell.Activate
End If
Application.ScreenUpdating = True
End Sub
