Optimiser le code pour accélérer le temps d'exécution

Version imprimable

Bonjour,

J'ai créé une macro dans un fichier dit de gestion, permettant d'aller récupérer des informations dans des fichiers remplis par des utilisateurs, qui sont formatés de telle sorte à ce que les informations à récupérer soient bien toujours aux mêmes endroits (même nom d'onglet, mêmes cellules).
Pour chaque utilisateur qui aura déposé son fichier dans le répertoire commun, je récupère (manuellement) le nom que je reporte dans mon fichier de gestion (ligne 2, colonnes 11, 13, 15...).
La macro permet ensuite d'ouvrir chacun des fichiers correspondant à ce nom, puis d'aller copier les données saisies par l'utilisateur, et de les coller dans le fichier de gestion. Comme certains utilisateurs peuvent ne remplir qu'une partie des champs et renvoyer d'autres données ultérieurement, je fais un test sur la présence d'information dans mon fichier de gestion : je n'écrase donc pas une information qui aurait été saisie auparavant.

Tout cela fonctionne bien, mais j'ai quand même l'impression que mon code est lourd (même si le temps d'exécution avec 2 fichiers test est assez raisonnable, je me pose la question quand j'en aurai 50 ou plus...). Y'a-t-il moyen de l'optimiser ? Est-ce que ce sont les ouvertures de fichiers qui sont longues ?

Par avance, merci pour vos suggestions.

Voici le code en question :
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 52 53 54 Sub BoucleFichiers() Dim CheminP As String, NomFichierGestion As String Dim NomP As String Dim i As Integer Dim FichierGestion As Workbook Dim OngletGestionRes As Worksheet Dim NomFichierP As String Dim FichierPro As Workbook Dim OngletP As Worksheet Application.ScreenUpdating = False 'Définit le répertoire contenant les fichiers CheminP = "C:\MonRep\" NomFichierGestion = ThisWorkbook.Name Set FichierGestion = ThisWorkbook Set OngletGestionRes = FichierGestion.Worksheets("Rés") OngletGestionRes.Unprotect 'Boucle sur tous les fichiers xls du répertoire. NomFichierP = Dir(CheminP & "*.xls*") Do While Len(NomFichierP) > 0 i = 11 Do While OngletGestionRes.Cells(2, i).Value <> "" NomP = OngletGestionRes.Cells(2, i).Value If NomFichierP Like "*" & NomP & "*" Then Workbooks.Open Filename:=CheminP & NomFichierP Set FichierPro = ActiveWorkbook Set OngletP = FichierPro.Worksheets("Donnees a recup") For lig = 3 To 38 If OngletGestionRes.Cells(lig, i) = "" Then OngletGestionRes.Cells(lig, i) = OngletP.Cells(lig + 3, 7) OngletGestionRes.Cells(lig, i + 1) = OngletP.Cells(lig + 3, 8) End If Next ' Récupération des 2 autres données intéressantes OngletGestionRes.Cells(55, i) = OngletP.Cells(2, 9) OngletGestionRes.Cells(56, i) = OngletP.Cells(3, 9) FichierPro.Close End If i = i + 2 Loop NomFichierP = Dir() Loop OngletGestionRes.Protect Application.ScreenUpdating = True End Sub

Bonjour Alqualonde.

Je ne suis pas certain que le code soit fonctionnel, surtout au niveau du tableau, et la correspondance entre les différentes lignes.

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
52
53
54
Sub BoucleFichiers()
    Dim CheminP As String, NomFichierGestion As String
    Dim NomP As String
    Dim i As Integer
    Dim FichierGestion As Workbook
    Dim OngletGestionRes As Worksheet
 
    Dim NomFichierP As String
    Dim FichierPro As Workbook
    Dim OngletP As Worksheet
 
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
 
    'Définit le répertoire contenant les fichiers
    CheminP = "C:\MonRep\"
 
    NomFichierGestion = ThisWorkbook.Name
 
    Set FichierGestion = ThisWorkbook
    Set OngletGestionRes = FichierGestion.Worksheets("Rés")
 
    OngletGestionRes.Unprotect
 
    'Boucle sur tous les fichiers xls du répertoire.
    NomFichierP = Dir(CheminP & "*.xls*")
    Do While Len(NomFichierP) > 0
        i = 11
        Do While OngletGestionRes.Cells(2, i).Value <> ""
            NomP = OngletGestionRes.Cells(2, i).Value
                If NomFichierP Like "*" & NomP & "*" Then
                    Set FichierPro = Workbooks.Open(CheminP & NomFichierP)
                    Set OngletP = FichierPro.Worksheets("Donnees a recup")
                    t = OngletP.Range("g6:g41") 'On met les données sous forme de tableau
                    FichierPro.Close False
                    With OngletGestionRes
                        .Cells(55, i).Resize(2).Value = OngletP.Cells(2, 9).Resize(2).Value
                        For lig = 3 To 38
                            If .Cells(lig, i).Value = "" Then .Cells(lig, i).Resize(, 2).Value = Application.Index(t, lig - 2, Array(1, 2))
                        Next
                    End With
                End If
            i = i + 2
        'Loop
        NomFichierP = Dir()
    Loop
 
    OngletGestionRes.Protect
 
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

08/06/2016, 17h00
Alqualonde

Bonjour thebenoit59, et merci pour ta réponse !

Hormis le dernier loop qui était commenté à tort et un petit end if qui manquait, ça avait l'air OK, mais j'avais une erreur d'exécution '-2147221080 (800401a8)' Erreur Automation, située, d'après le mode débogage, sur la première ligne du With :

Code:

.Cells(55, i).Resize(2).Value = OngletP.Cells(2, 9).Resize(2).Value

En cherchant des erreurs similaires sur le Net, ça avait l'air lié à un problème de .close. J'ai déplacé le FichierPro.close après le bloc With et ça marche !!!

Au passage, j'ai remplacé le

Code:

Range("g6:g41")

par

Code:

Range("g6:h41")

pour bien tout copier.

Merci beaucoup !! Ca tourne effectivement beaucoup plus vite... quasi instantané !
08/06/2016, 17h03
thebenoit59

Effectivement, maintenant que tu soulignes les problèmes que tu as rencontré, ça me paraît logique.
Content que ça fonctionne alors.