Autres [RÉSOLU] Qu'est-ce qui ne va pas dans la macro Centrer Rectangles?

[un internaute]

Bonjour le forum et Bonne Année à tous
Comme dit dans le titre
Merci pour vos éventuels retours
Cordialement

 

[un internaute]

Bonjour le forum et Bonne Année à tous
Comme dit dans le titre
Merci pour vos éventuels retours
Cordialement

 

[un internaute]

J'ai gratté encore un peu et ça fonctionne
Toutes mes excuses
Ou alors il y a mieux à faire je suis preneur
Cordialement

Sub CentrerRectangles()
    Dim Largeur_Totale As Double, Espacement As Double, Largeur_Cumulee_des_Boutons As Double
    Dim Shp1 As Shape, Shp2 As Shape
    Set Shp1 = ActiveSheet.Shapes("Rectangle 2")
    Set Shp2 = ActiveSheet.Shapes("Rectangle 1")

    'Calcul des largeurs
    Largeur_Totale = Range("H1").Left
    Largeur_Cumulee_des_Boutons = Shp1.Width + Shp2.Width

    'Calcul des espacements de part et d'autre de chaque bouton
    Espacement = (Largeur_Totale - Largeur_Cumulee_des_Boutons) / 3

    'Centrage horizontal
    Shp1.Left = Range("A1").Left + Espacement
    Shp2.Left = Range("A1").Left + Shp1.Width + (2 * Espacement)
End Sub

 

[job75]

Bonjour un internaute, le forum,

J'ai revu la macro dans ThisWorlbook :

Private Sub Workbook_Open()
Dim Sh As Worksheet, An%
An = Year(Date)
For Each Sh In ThisWorkbook.Worksheets
   Sh.Visible = IIf(Sh.Name = "Retraites " & An, xlSheetVisible, xlSheetVeryHidden)
Next
Range("A1").Select
Application.OnTime 1, "Centrer" 'lance la macro
End Sub

Et celle-ci dans Module1 qui tourne en arrière-plan :

Sub Centrer()
Dim t#, d, x#
Do
    t = Timer + 1 'attente 1 seconde
    While Timer < t And Timer < 86400: DoEvents: Wend
    Set d = ActiveSheet.DrawingObjects
    If d.Count > 1 Then
        x = ([A1].MergeArea.Width - d(1).Width - d(2).Width) / 3
        d(1).Left = x: d(1).Top = ([A1].Height - d(1).Height) / 2
        d(2).Left = d(1).Width + 2 * x: d(2).Top = ([A1].Height - d(2).Height) / 2
    End If
Loop
End Sub

Ouvrez le fichier joint et voyez ce qui se passe si vous déplacez les rectangles.

A+

 

[job75]

En intervertissant les objets et en évitant le "gap" du début :

Sub Centrer()
Dim d, x#, t#
Do
    Set d = ActiveSheet.DrawingObjects
    If d.Count > 1 Then
        x = ([A1].MergeArea.Width - d(1).Width - d(2).Width) / 3
        d(2).Left = x: d(2).Top = ([A1].Height - d(2).Height) / 2
        d(1).Left = d(2).Width + 2 * x: d(1).Top = ([A1].Height - d(1).Height) / 2
    End If
    t = Timer + 1 'attente 1 seconde
    While Timer < t And Timer < 86400: DoEvents: Wend
Loop
End Sub

 

[un internaute]

Bonjour job 75
Lorsque j'ai mis à zéro le programme j'ai supprimé par inadvertance le titre et ça change tout pour ta macro
Toutes mes excuses
Je fais que des C$$$$$$$S actuellement
Cordialement

 

[job75]

Le titre ne pose guère de problème et s'il n'y a qu'un rectangle à centrer on utilisera :

Sub Centrer()
Dim d, x#, t#
Do
    Set d = ActiveSheet.DrawingObjects
    If d.Count = 1 Then
        x = ([A1].MergeArea.Width - d(1).Width) / 2
        d(1).Left = x: d(1).Top = 16 + ([A1].Height - d(1).Height - 16) / 2
    ElseIf d.Count > 1 Then
        x = ([A1].MergeArea.Width - d(1).Width - d(2).Width) / 3
        d(2).Left = x: d(2).Top = 16 + ([A1].Height - d(2).Height - 16) / 2
        d(1).Left = d(2).Width + 2 * x: d(1).Top = 16 + ([A1].Height - d(1).Height - 16) / 2
    End If
    t = Timer + 1 'attente 1 seconde
    While Timer < t And Timer < 86400: DoEvents: Wend
Loop
End Sub

Par ailleurs pour naviguer entre les feuilles on peut utiliser ces 2 macros :

Sub Precedente()
'se lance par les touches Ctrl+P
On Error Resume Next
With ActiveSheet
    Sheets(.Index - 1).Visible = xlSheetVisible
    Sheets(.Index - 1).Activate
    .Visible = xlSheetVeryHidden
End With
End Sub

Sub Suivante()
'se lance par les touches Ctrl+S
On Error Resume Next
With ActiveSheet
    Sheets(.Index + 1).Visible = xlSheetVisible
    Sheets(.Index + 1).Activate
    .Visible = xlSheetVeryHidden
End With
End Sub

Elles se lancent par les touches de raccourci Ctrl+P et Ctrl+S.

J'ai aussi revu la macro Workbook_Open car elle pouvait beuguer.

A+

 

[un internaute]

Bonjour job75
Super ça fonctionne effectivement il y avait quelques bugs
Je vais regarder ça de plus près
Merci pour ton implication pour le nonagénaire
Bonne fin de WE
Cordialement

 

[job75]

Bonjour un internaute, le forum,

Je peaufine mais c'est nécessaire.

Cette macro va bien même si l'on n'ouvre pas le fichier pendant plusieurs années :

Private Sub Workbook_Open()
Dim Sh As Worksheet, An%, A%
An = Year(Date)
Do While Not FeuilleExiste("Retraites " & An)
    A = An
    Do
        A = A - 1
        If A < 2000 Then MsgBox "Pas de feuilles !!": Exit Sub 'sécurité
    Loop While Not FeuilleExiste("Retraites " & A)
    With Sheets("Retraites " & A): .Visible = xlSheetVisible: .Select: End With
    NouvelleAnnee 'lance la macro autant de fois qu'il le faut
Loop
Sheets("Retraites " & An).Visible = xlSheetVisible
For Each Sh In Worksheets
   If Sh.Name <> "Retraites " & An Then Sh.Visible = xlSheetVeryHidden
Next
Range("A1").Select
Application.OnTime 1, "Centrer" 'lance la macro
End Sub

A+

 

[un internaute]

Bonjour un internaute, le forum,

Je peaufine mais c'est nécessaire.

Cette macro va bien même si l'on n'ouvre pas le fichier pendant plusieurs années :

Private Sub Workbook_Open()
Dim Sh As Worksheet, An%, A%
An = Year(Date)
Do While Not FeuilleExiste("Retraites " & An)
    A = An
    Do
        A = A - 1
        If A < 2000 Then MsgBox "Pas de feuilles !!": Exit Sub 'sécurité
    Loop While Not FeuilleExiste("Retraites " & A)
    With Sheets("Retraites " & A): .Visible = xlSheetVisible: .Select: End With
    NouvelleAnnee 'lance la macro autant de fois qu'il le faut
Loop
Sheets("Retraites " & An).Visible = xlSheetVisible
For Each Sh In Worksheets
   If Sh.Name <> "Retraites " & An Then Sh.Visible = xlSheetVeryHidden
Next
Range("A1").Select
Application.OnTime 1, "Centrer" 'lance la macro
End Sub

A+

 

[un internaute]

Re job75
C'est sans fin!!!
Encore merci
Cordialement