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 ?