XL 2016 Mettre la feuille proportionnellement à la taille de l'écran

[ReneDav14000]

Bonsoir le forum,
J'ai appliqué le code qui m'a été donné par patricktoulon, que je remercie, afin que mes feuilles de calcul soient proportionnelles à la taille des écrans où l'application va être installée.
Mais je rencontre un problème. A chaque fois que je reviens sur la feuille de calcul "Accueil", la taille de ma feuille change sans que je comprenne pourquoi, et voilà ce que ça donne après 3 passages par la feuille "Accueil".
Merci par avance pour votre aide ou vos conseils.

Voici le code ;

Private Sub Worksheet_Activate()
    Dim Shap, d
    Application.ScreenUpdating = False
    zoomexequo
    Range("A1").Select
    Application.ScreenUpdating = True
    BubleWaterWatch_GO_Range
    DoEvents
        With ActiveSheet
        Set Shap = .Shapes("image 4")
        d = GetDimPositionShapeCenterRange([b9:f22], Shap)
        Shap.Left = d(0): Shap.Top = d(1): Shap.Width = d(2)
    End With
End Sub

'*******************************************************

Private Sub Worksheet_Deactivate()
    dimOriginale
End Sub
'*******************************************************
Sub zoomexequo()
    Dim RnG As Range, RnG2
    Application.DisplayFullScreen = True
    Set RnG = [A1:U32]
    With RnG
        .RowHeight = 15: .ColumnWidth = 10.71
        Set RnG2 = ActiveWindow.Panes(1).VisibleRange
        Set RnG2 = RnG2.Resize(, RnG2.Columns.Count)
        coeffw = RnG2.Width / .Width
        coeffh = RnG2.Height / .Height
        .RowHeight = .RowHeight * coeffh
        .ColumnWidth = .ColumnWidth * coeffw
    End With
End Sub
'*******************************************************
Sub dimOriginale()
    Dim RnG As Range
    Set RnG = Feuil1.[A1:U32]
    Application.DisplayFullScreen = False
    With RnG
        .RowHeight = 15: .ColumnWidth = 10.71
    End With
End Sub

 

[ReneDav14000]

Bonjour à tous,
J'ai mis les codes dans ThisWorkBook, je vais voir à l'usage ce que cela donne.
Je vous tiens au courant