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.
des idées SVP ?
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![]()
Partager