Autres Possibilité de faire une macro?

[un internaute]

Bonjour le forum
J'ai des fichiers avec plusieurs onglets qui ont des Rectangles ou Zone de texte avec des N°
Pour centrer il faut modifier soit le N° du Rectangle ou de la Zone de texte.
Soit je retape tous les N° de Rectangle ou Zone de texte par exemple Rectangle 1 ou remplace Zone de texte par Rectangle
Je ne vois pas comment on pourrait y échapper
Merci pour vos éventuels retours

Option Explicit
Sub CentrerRectangle()
  Dim Shp1 As Shape, Shp2 As Shape, Shp3 As Shape
  Set Shp1 = ActiveSheet.Shapes("Rectangle 19")
  Shp1.Left = ([G1].Left - Shp1.Width) / 2               'G1 = Nom cellule juxtaposant le domaine à centrer
End Sub

 

[job75]

Bonjour un internaute,

Pour centrer il faut modifier

Il n'y a rien à modifier.

A+

 

[un internaute]

Bonjour job75
Rien modifier?
Comment tu fais quand le rectangle est 38 et dans la macro c'est 11?

 

[job75]

Par exemple :

Sub CentrerRectangle()
    Dim o As Object
    For Each o In DrawingObjects
        o.Left = [G1].Left + ([G1].Width - o.Width) / 2
    Next
End Sub

 

[un internaute]

Variable non définie

DrawingObjects

 

[Dranreb]

Bonjour.
Si les Shape sont déjà à peu près bien placés vous pouvez les centrer dans les plages qu'ils couvrent :

Sub CentrerShapes()
   Dim Shp As Shape, Rng As Range
   For Each Shp In ActiveSheet.Shapes
      If Shp.Name Like "Rect*" Then CentrerShape Shp, _
         Application.Range(Shp.TopLeftCell, Shp.BottomRightCell)
      Next Shp
   End Sub
Sub CentrerShape(ByVal Shp As Shape, ByVal Rng As Range)
   Shp.Left = Rng.Left + (Rng.Width - Shp.Width) / 2
   Shp.Top = Rng.Top + (Rng.Height - Shp.Height) / 2
   End Sub

Sinon, renommez les de telle sorte que leurs noms contiennent les adresses des plages dans lesquelles il doivent être centrés et récupérez les pour les y centrer :

Sub CentrerShapesPour()
   Dim Shp As Shape, Rng As Range
   For Each Shp In ActiveSheet.Shapes
      If Shp.Name Like "Pour:*" Then CentrerShape Shp, ActiveSheet.Range(Mid$(Shp.Name, 6))
      Next Shp
   End Sub

 

[job75]

Variable non définie

DrawingObjects

Si la macro est dans un module standard :

ActiveSheet.DrawingObjects

Si la macro est dans le code de la feuille ActiveSheet n'est pas nécessaire.

 

[un internaute]

Module standard
C'est ça?

Sub CentrerRectangle()
    Dim o As Object
     ActiveSheet.DrawingObjects
        o.Left = [G1].Left + ([G1].Width - o.Width) / 2
    Next
End Sub

Si c'est ça n'aime pas Next sans for

 

[job75]

C'est ça mais bien sûr vous avez oublié For Each o In.

 

[un internaute]

Oh! P$$$$N
Ça se voit que je sors du CHU après 5 semaines d'hospitalisation!!!
Merci job75 et toutes mes excuses pour l'oubli
Bonne fin de soirée

 

[un internaute]

J'ai fait ça en "bricolant" à droite à gauche mais le seul truc qui me gène c'est qu'il faut absolument déplacer le rectangle dans la dernière colonne (la 1ère il y est souvent)
Peut-être y a t-il mieux à faire
Cordialement

Sub CentrageDesFormes()     'Placer le rectangle dans la 1ère & dernière colonne avant le centrage
Dim Sh As Shape
Dim Ws As Worksheet
  For Each Ws In Sheets
    For Each Sh In Ws.Shapes
      Select Case Sh.Type
        Case 1, 17
          If Sh.TopLeftCell.Address(0, 0) = "A1" Then
            Sh.Left = (Sh.BottomRightCell.Left + Sh.BottomRightCell.Width) / 2 - Sh.Width / 2
          End If
      End Select
    Next Sh
  Next Ws
End Sub