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

[un internaute]

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

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

 

[job75]

Bonjour un internaute,

Utilisez :

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+

 

[mapomme]

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.

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

 

[un internaute]

Bonjour à tous les deux
Job75
Ok mais comment tu trouves la ligne ci-dessous?

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

 

[job75]

Autre solution, un peu plus simple :

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?

margehaut = 27.75 'place pour le titre

En sélectionnant le 1er rectangle et en exécutant le code :

MsgBox Selection.Top

Bonjour mapomme.

 

[job75]

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 :

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

 

[job75]

Le texte de la 1ère Shape n'était pas totalement affiché, j'ai augmenté la hauteur de la ligne 1.

 

[job75]

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 :

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 :

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 :

Sub Cadrer()
CentrerRectangles [A1:F1], 3, 1, 26, 5, 10
CentrerRectangles [G1:I1], 1, 1, 15, 15, 30
End Sub

A+

 

[un internaute]

Bonjour le forum
Merci à Job75, mapomme
SUPER
Qu'est-ce qu'il ne faut pas faire pou aider un "vieux"
Encore un GRAND merci à vous 2
Bonne semaine à tous