Redimensionnement graphiques

[eside]

Bonjour,

Je vous expose un peu mon problème. Je possede des graphiques sur une page que j'aimerais bien pouvoir repositionner, redimensionner pour qu'ils se trouvent par 6 sur une page A4 en format portrait. J'ai déjà créé une subroutine qui va les grouper par 6 (ou moins s'il y en a moins de 6) et les placer sur une page A4. Pour celà je récupère la taille de la page grâce aux saut de page (voir code ci-dessous).
Tout marche bien lorsque je le fait pas à pas grâce au debugger mais lorsque tout s'effectue d'une traite, les graphiques ne sont pas du tout à la bonne taille (en fait ils sont beaucoup plus grand). Tout à l'air de bien se dérouler jusqu'à la dernière boucle for.
J'ai même essayé de mettre un sleep avant le redimensionnement mais rien n'y a fait, j'en fait donc appel à vous et vos idées quelles qu'elles soient 🙂

Sub tri_graphe()
    Dim ch As ChartObject
    Dim Grap As String
    Dim Hauteur As Long
    Dim Largeur As Long
    Dim X As Long
    Dim Y As Long
    Dim graphe_count As Integer
    
    X = 0
    Y = 0
    graph_count = 0
    largeur_page = 0
    hauteur_page = 0
    
    'La variable count nous permet de replacer différement un graphique sur deux
    Count = 0
    
    For Each ch In ActiveSheet.ChartObjects
        Grap = ch.Name
        
        Hauteur = ActiveSheet.Shapes(Grap).Height
        Largeur = ActiveSheet.Shapes(Grap).Width
        
        'On test si on est en fin de groupe de 2
        If Count = 1 Then
            ActiveSheet.Shapes(Grap).Left = Y 'redéfinir position dans feuille
            ActiveSheet.Shapes(Grap).Top = X 'redéfinir position dans feuille

            X = X + Hauteur + 0
            Y = 0
        Else
            ActiveSheet.Shapes(Grap).Left = Y 'redéfinir position dans feuille
            ActiveSheet.Shapes(Grap).Top = X 'redéfinir position dans feuille
            
            Y = Y + Largeur
        End If
        
        'On incrémente le compteur
        If Count = 1 Then
            Count = 0
        Else
            Count = Count + 1
        End If
        graph_count = graph_count + 1
         
    Next ch
    
    Sheets(2).Select
    arrondi_nbre_graphique = Application.WorksheetFunction.RoundDown(graph_count / 6, 0)
    j = 0
    Do While j < arrondi_nbre_graphique
        ActiveSheet.Shapes.Range(Evaluate("transpose(ROW(" & (j * 6) + 1 & ":" & (j * 6) + 6 & "))")).Select
        Selection.ShapeRange.Group.Select
        graph_count = graph_count - 6
        j = j + 1
    Loop
    If graph_count <> 0 Then
        ActiveSheet.Shapes.Range(Evaluate("transpose(ROW(" & j + 1 & ":" & j + graph_count & "))")).Select
        Selection.ShapeRange.Group.Select
        j = j + 1
    End If
    
    Dim nbre_groupe As Integer
    nbre_groupe = j
    
    ActiveSheet.PageSetup.Orientation = xlPortrait
    ActiveSheet.PageSetup.PaperSize = xlPaperA4
    ActiveSheet.PageSetup.CenterHorizontally = True
    
    CibleV = ActiveSheet.VPageBreaks(1).Location.Column - 1 ' nombre de colonnes dans la 1ere page
    CibleH = ActiveSheet.HPageBreaks(1).Location.Row - 1 ' nombre de ligne dans la 1ere page
    
    For i = 1 To CibleV
        largeur_page = largeur_page + Cells(1, i).Width ' calcul largeur premiere page imprimable
    Next i
    For i = 1 To CibleH
        hauteur_page = hauteur_page + Cells(i, 1).Height ' calcul largeur premiere page imprimable
    Next i
    
    Do While hauteur_page = 0
    Loop
    
    Do While largeur_page = 0
    Loop
    
    For i = 1 To (nbre_groupe)
        With ActiveSheet.Shapes(i)
            .Width = largeur_page
            .Height = hauteur_page
            .Top = 0
        End With
    Next i
    
End Sub

 

[eside]

Re : Redimensionnement graphiques

Petit UP au cas ou quelqu'un aurait la reponse mais n'oserait pas se lacher (et aussi pcq je suis toujours bloqué 😛 )