Accélérer le code suivant

Version imprimable

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 :aie:

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

Code:

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 ? :mouarf:

13/06/2013, 20h07
SfJ5Rpw8
bonsoir,
Citation:
Code:

1 2 3 4 ... Dim xlapp As New Excel.Application ..
pourquoi lancer une application excel supplémentaire ?
13/06/2013, 20h21
Jean-Philippe André

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

Bonjour,

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

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

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

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

Code:

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

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:

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