Discussion :

[Jean-Philippe André]

Hello tous,

je suis frustré avec un bout de code simplissime, mais dont les performances me déplaisent.

Comme je n'arrive pas à tourner en dessous de la seconde pour faire le traitement, j'en appelle à vos idées

Le code boucle sur les fichiers Xls contenus dans un répertoire, les mets en page et les enregistre sous un autre nom.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Sub BoucleFichiers()
    Dim Chemin As String, Fichier As String
    Dim xlwbk As Workbook
    Dim xlwsh As Worksheet
    Dim User As String
    Dim CurrentPath As String
    Dim NewPath As String
    'Définit le répertoire contenant les fichiers
    Chemin = Me.Txt_Path.Value '& "\"
    Dim xlapp As New Excel.Application
    'Boucle sur tous les fichiers xls du répertoire.
    Fichier = Dir(Chemin & "*.xls")
    'Utilisez la syntaxe suivante pour boucler sur tous les types de fichiers:
    'Fichier = Dir(Chemin & "*.*")
    xlapp.Visible = False
    xlapp.ScreenUpdating = False
    Do While Len(Fichier) > 0
        'écrit le résultat dans la fenêtre d'exécution (Ctrl+G).
        'Debug.Print "début " & Now
        If Chemin & Fichier <> ThisWorkbook.FullName Then
            Set xlwbk = xlapp.Workbooks.Open(Chemin & Fichier)
            Set xlwsh = xlwbk.Worksheets(1)
            xlwsh.Range("H:I").EntireColumn.Hidden = True
            With xlwsh.PageSetup
                .BottomMargin = 70.8661417322835 'Application.CentimetersToPoints(2.5)
                .FooterMargin = 36.8503937007874 'Application.CentimetersToPoints(1.3)
                .HeaderMargin = 36.8503937007874 'Application.CentimetersToPoints(1.3)
                .LeftMargin = 53.8582677165354 'Application.CentimetersToPoints(1.9)
                .Orientation = xlLandscape
                .PrintArea = "A1:O" & xlwsh.Range("K65536").End(xlUp).Row
                .RightMargin = 53.8582677165354 'Application.CentimetersToPoints(1.9)
                .TopMargin = 70.8661417322835 'Application.CentimetersToPoints(2.5)
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
            User = Replace(xlwsh.Range("B3").Value, " ", "_")
            Set xlwsh = Nothing
            CurrentPath = xlwbk.FullName
            NewPath = xlwbk.Path & "\" & Left(xlwbk.Name, 29) & User & ".xls"
            xlwbk.Save 'As xlwbk.Path & "\" & Left(xlwbk.Name, 29) & User & ".xls"
            xlwbk.Close True
            Name CurrentPath As NewPath
            'Debug.Print Chemin & Fichier
            'Debug.Print "fin " & Now
        End If
        Fichier = Dir()
    Loop
    xlapp.ScreenUpdating = True
    xlapp.Quit
End Sub

des idées SVP ?

[SfJ5Rpw8]

bonsoir,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
...
Dim xlapp As New Excel.Application
..

pourquoi lancer une application excel supplémentaire ?

[Jean-Philippe André]

J'avais initialement codé ca sous Access, je l'ai gardé

[Patrice740]

Bonjour,

le PageSetup classique est excessivement lent, essaies avec la macroxl4 qui est beaucoup plus rapide :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
MacroExcel4 = "PAGE.SETUP(en_tête, pied_pg, marge_gch, _
marge_dr, marge_haut, marge_bas, no_lig_col, quadrillage, _
centr_hor, centr_vert, orient, papier, échelle, no_pg, ordre_impr, _
cellules_nb, qualité, marge_en_tête, marge_pied_pg, annot, brouillon)"
Application.ExecuteExcel4Macro MacroExcel4

Cordialement
Patrice

[Jean-Philippe André]

Héhé, merci pour cette piste, que je vais m'empresser d'adapter à mon cas !

Merci, j'ai donc pu adapter et obtenir un temps de réponse nettement plus efficace !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Application.ScreenUpdating = False
    Do While Len(Fichier) > 0
        If Chemin & Fichier <> ThisWorkbook.FullName Then
            Set xlwbk = Application.Workbooks.Open(Chemin & Fichier)
            Set xlwsh = xlwbk.Worksheets(1)
            xlwsh.Range("H:I").EntireColumn.Hidden = True
 
            MacroExcel4 = "PAGE.SETUP(,,0.75,0.75,0.98,0.98)"
            'MacroExcel4 = "PAGE.SETUP(en_tête, pied_pg, marge_gch," & _
                            "marge_dr, marge_haut, marge_bas, no_lig_col, quadrillage, " & _
                            "centr_hor, centr_vert, orient, papier, échelle, no_pg, ordre_impr, " & _
                            "cellules_nb, qualité, marge_en_tête, marge_pied_pg, annot, brouillon)"
            Application.ExecuteExcel4Macro MacroExcel4
 
            With xlwsh.PageSetup
                .Orientation = xlLandscape
                .PrintArea = "A1:O" & xlwsh.Range("K65536").End(xlUp).Row
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
            User = Replace(xlwsh.Range("B3").Value, " ", "_")
            Set xlwsh = Nothing
            CurrentPath = xlwbk.FullName
            NewPath = xlwbk.Path & "\" & Left(xlwbk.Name, 29) & User & ".xls"
            xlwbk.Save
            xlwbk.Close True
            Name CurrentPath As NewPath
        End If
        Fichier = Dir()
 
    Loop
    Application.ScreenUpdating = True

[Patrice740]

Bonjour,

Le PageSetup classique est relativement lent car les propriétés sont modifiées l'une après l'autre alors qu'avec la MacroExcel4 elle sont toutes modifiées en un seul appel.
Tu devrais encore gagner un peu de temps en passant un maximum d'arguments dans MacroExcel4 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
            MacroExcel4 = "PAGE.SETUP(,,0.75,0.75,0.98,0.98,False,False,True,False,2,,True)"
            'MacroExcel4 = "PAGE.SETUP(en_tête, pied_pg, marge_gch,"marge_dr, marge_haut, marge_bas, _
                           no_lig_col, quadrillage, centr_hor, centr_vert, orient, papier, échelle, no_pg, ordre_impr, " & _
                            "cellules_nb, qualité, marge_en_tête, marge_pied_pg, annot, brouillon)"
            Application.ExecuteExcel4Macro MacroExcel4
 
            xlwsh.PageSetup.PrintArea = "A1:O" & xlwsh.Range("K65536").End(xlUp).Row

Cordialement
Patrice