Autres [RÉSOLU] Comment centrer les rectangles sur plage A:C

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

un internaute

XLDnaute Impliqué
Bonjour le forum
Il y a quelques jours danielco et fanch55 ont fait 2 petites macros. Mais comme il fallait en garder une j'ai gardé celle du fichier toto 2026
Mais sur ce fichier c'est plus compliqué il y a 6 rectangles
Un des deux pourraient-ils me faire cette petite macro?
Merci d'avance
Cordialement


VB:
Sub CentrerRectangles()
  Dim Shp1 As Shape, Shp2 As Shape, Shp3 As Shape
  Set Shp1 = ActiveSheet.Shapes("Rectangle 30")
  Shp1.Left = ([K1].Left - Shp1.Width) / 2
  Set Shp2 = ActiveSheet.Shapes("Rectangle 32")
  Shp2.Left = (Shp1.Left - Shp2.Width) / 2
  Set Shp3 = ActiveSheet.Shapes("SeancesPlus")
  Shp3.Left = (Shp1.Width + Shp1.Left) + ([K1].Left - (Shp1.Width + Shp1.Left) - Shp3.Width) / 2
End Sub
 

Pièces jointes

Bonjour un internaute,

Utilisez :
VB:
Sub CentrerRectangles()
Dim ref As Range, margehaut, s As Shape, n, H, W, ecartV, ecartH
Set ref = [A1:C1]
margehaut = 27.75 'place pour le titre
For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, ref) Is Nothing Then
        n = n + 1
        If n > 6 Then
            s.Delete 'sécurité
        Else
            If n = 1 Then
                H = s.Height: ecartV = (ref.Height - margehaut - 2 * H) / 2
                W = s.Width: ecartH = (ref.Width - 3 * W) / 4
            Else
                s.Height = H
                s.Width = W
            End If
            s.Top = IIf(n Mod 2, margehaut, margehaut + H + ecartV)
            Select Case n
                Case 1, 2: s.Left = ecartH
                Case 3, 4: s.Left = 2 * ecartH + W
                Case 5, 6: s.Left = 3 * ecartH + 2 * W
            End Select
        End If
    End If
Next
End Sub
A+
 

Pièces jointes

Bonjour @un internaute 🙂, @job75 😉,

Une fonction générique qui centre une forme sur une plage en largeur ou en hauteur ou bien dans les deux sens.
VB:
Sub CentrerFormePlage(xform As Shape, xplage As Range, Optional dimension = 0)
' xform est une forme (type Shape)
' xplage est une plage de cellules (type Range)
' dimension       : 1 ou "w" ou "W" ou "l" (lettre) ou "L" ou "x" ou "X" pour centrer en largeur
'                 : 2 ou "h" ou "H" ou "y" ou "Y" pour centrer en hauteur
'                 : n'importe quoi d'autre ou rien pour centrer en largeur et en hauteur
Dim oldSheet As Worksheet, Xcentre#, Ycentre#
   If xplage.Areas.Count > 1 Then MsgBox "Echec centrage car la plage est multi-zones!", vbCritical: Exit Sub
   If Not xplage.Parent Is xform.Parent Then MsgBox "Echec centrage car la forme et la plage ne sont pas sur la même feuille!", vbCritical: Exit Sub
   Set oldSheet = ActiveSheet: xplage.Parent.Select
   Xcentre = xplage.Left + xplage.Width / 2: Ycentre = xplage.Top + xplage.Height / 2
   If IsMissing(dimension) Then dimension = 0
   Select Case dimension
      Case 1, "w", "W", "l", "L", "x", "X"
         xform.Left = Xcentre - xform.Width / 2
      Case 2, "h", "H", "y", "Y"
         xform.Top = Ycentre - xform.Height / 2
      Case Else
         xform.Left = Xcentre - xform.Width / 2
         xform.Top = Ycentre - xform.Height / 2
   End Select
   oldSheet.Select
End Sub
 

Pièces jointes

Dernière édition:
Bonjour à tous les deux
Job75
Ok mais comment tu trouves la ligne ci-dessous?
VB:
margehaut = 27.75 'place pour le titre
On ne peut pas faire un truc très simple un "passe partout" si je puis m'exprimer ainsi en modifiant bien sûr les plages et suivant qu'il y ai 1, 2,3 Rectangles par exemple
Mais pour le fichier joint on fait comment stp?
Excuses les questions certainement un peu C$N!!
Bien cordialement
 

Pièces jointes

Autre solution, un peu plus simple :
VB:
Sub CentrerRectangles()
Dim ref As Range, margehaut, ecartV, ecartH, H, W, s As Shape, n
Set ref = [A1:C1]
margehaut = 27.75 'place pour le titre
ecartV = 5 'modifiable
ecartH = 10 'modifiable
H = (ref.Height - margehaut - 2 * ecartV) / 2
W = (ref.Width - 4 * ecartH) / 3
For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, ref) Is Nothing Then
        n = n + 1
        If n > 6 Then
            s.Delete 'sécurité
        Else
            s.Height = H
            s.Width = W
            s.Top = IIf(n Mod 2, margehaut, margehaut + H + ecartV)
            Select Case n
                Case 1, 2: s.Left = ecartH
                Case 3, 4: s.Left = 2 * ecartH + W
                Case 5, 6: s.Left = 3 * ecartH + 2 * W
            End Select
        End If
    End If
Next
End Sub
Ok mais comment tu trouves la ligne ci-dessous?
VB:
margehaut = 27.75 'place pour le titre
En sélectionnant le 1er rectangle et en exécutant le code :
VB:
MsgBox Selection.Top
Bonjour mapomme.
 

Pièces jointes

Dernière édition:
D'une manière générale je pense que le plus simple est d'adapter la macro à chaque plage et au nombre de Shapes.

Par exemple pour le dernier fichier du post #4 :
Code:
Sub CentrerRectangles()
Dim ref As Range, margehaut, ecartV, ecartH, H, W, s As Shape, n
'---1ère plage---
Set ref = [A1:F1]
margehaut = 26 'place pour le titre
ecartV = 5 'modifiable
ecartH = 10 'modifiable
H = ref.Height - margehaut - ecartV
W = (ref.Width - 4 * ecartH) / 3
For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, ref) Is Nothing Then
        n = n + 1
        s.Height = H
        s.Width = W
        s.Top = margehaut
        Select Case n
            Case 1: s.Left = ecartH
            Case 2: s.Left = 2 * ecartH + W
            Case 3: s.Left = 3 * ecartH + 2 * W
        End Select
    End If
Next
'---2ème plage, centrage simple de la Shape existante---
Set ref = [G1:I1]
For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, ref) Is Nothing Then
        s.Top = (ref.Height - s.Height) / 2
        s.Left = ref.Left + (ref.Width - s.Width) / 2
    End If
Next
End Sub
 

Pièces jointes

Bonjour le forum,

Bon comme mapomme j'ai créé une macro générique, c'est à dire paramétrée fonctionnant dans tous les cas :
VB:
Sub CentrerRectangles(ref As Range, nH, nV, margeHaut, ecartV, ecartH)
Dim H, W, s As Shape, n, i, j
H = (ref.Height - margeHaut - nV * ecartV) / nV
W = (ref.Width - (nH + 1) * ecartH) / nH
For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, ref) Is Nothing Then
        n = n + 1
        s.Height = H
        s.Width = W
        i = (n - 1) Mod nV
        s.Top = ref.Top + margeHaut + i * (H + ecartV)
        j = Int((n - 1) / nV)
        s.Left = ref.Left + ecartH + j * (W + ecartH)
    End If
Next
End Sub
Dans le fichier toto 2026.xls elle est lancée par :
VB:
Sub Cadrer()
CentrerRectangles [A1:C1], 3, 2, 27.75, 5, 10
CentrerRectangles [I2:I4], 1, 1, 4, 4, 4
End Sub
et dans le fichier toto_Charges.xls par :
VB:
Sub Cadrer()
CentrerRectangles [A1:F1], 3, 1, 26, 5, 10
CentrerRectangles [G1:I1], 1, 1, 15, 15, 30
End Sub
A+
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Retour