Boucle surchargée avec multiples insertions de formules : comment l'optimiser ?

Version imprimable

Bonjour,

J’ai récupéré un code vba et l’ai retravaillé afin qu’il corresponde à mes besoins :
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 Option Explicit Sub MergeAllWorkbooks() Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim Repertoire As FileDialog Dim ligne As Long Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker) If Repertoire.Show = False Then Exit Sub MyPath = Repertoire.SelectedItems(1) If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If FilesInPath = Dir(MyPath & "*.xl*") With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ' création d'autant de nouvelles lignes qu'il y a de fichiers : on compte le nombre de fichiers avec un "do while xxx <>"", on copie une ligne formatée au format souhaité et on insère le nombre de lignes correspondantes. Cela n'a pas l'air de prendre beaucoup de temps car si j'exécute seulement ce bout de code cela fonctionne rapidement sur des dossier avec 300 fichiers excel... Do While FilesInPath <> "" filep = MyPath & FilesInPath FilesInPath = Dir() Range("B" & ligne).Formula = "='" & filep & "'!toto1" Range("C" & ligne).Formula = "='" & filep & "'!toto2" Range("D" & ligne).Formula = "='" & filep & "'!toto3" (idem sur une quarantaine de colonnes !) ligne = ligne + 1 Loop ExitTheSub: With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With End Sub
Cela marche bien quand il y a une dizaine de fichiers excel dans le dossier mais je reçois une erreur 400 quand il y a beaucoup de fichiers excel.

Je suppose que cela vient du fait que ma boucle n'est pas assez performante.
Je crois que c'est l'insertion d'une quarantaine de formule sur chaque ligne qui doit poser problème mais je ne vois pas comment optimiser ça ?

Pourriez-vous m’aider svp :) ?

J'ai pensé à inscrire mes nom de cellules (toto1, toto2, toto3, ...) dans la ligne supérieur du tableau excel (en ligne 1 par exemple) une fois pour toutes pour ensuite insérer uniquement sur la première colonne une formule du type

Code:

=chemin du fichier excel.xls'! & INDIRECT("A1")

... et étendre les formule jusqu'à la fin du tableau (après être sorti de la boucle).
Je pensais que cela serait moins consommateur de ressources.
Mais ça ne semble pas marcher (#REF).
Est-ce une piste à creuser selon vous... ?

28/02/2013, 10h35
Oliv-

Salut,
Peux tu expliquer ce que tu veux obtenir ?
Pour parcourir des fichiers il vaut mieux utiliser FSO
28/02/2013, 11h02
Thierry360

Je veux créer un tableau de synthèse de plusieurs fichiers excel.
Tous ces fichiers excel ont des cellules nommées de façon identique (toto1 est le nom d'une cellule présente dans tous les fichiers excel).

Le tableau est structuré ainsi :
- 1 ligne par fichier
- 40 colonnes, avec une variable par colonne (même fichier mais référence à une cellule nommée différemment)

Toutes les cellules du tableau doivent être remplies avec des liens (et pas directement avec les valeurs des cellules en dur).

Bonjour

j'ai testé ton code (avec un léger remaniement) sur 750 fichiers et 120 colonnes sans erreur

J'ai ajouté un dovents

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
Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String, Filep As String
Dim Repertoire As FileDialog
Dim Ligne As Long
 
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With
 
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
If Repertoire.Show = True Then
    MyPath = Repertoire.SelectedItems(1)
    Set Repertoire = Nothing
 
    If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
 
    FilesInPath = Dir(MyPath & "*.xl*")
    Do While FilesInPath <> ""
        Filep = Replace(MyPath & FilesInPath, "'", "''")    'Au cas où le nom contient l'apostrophe
 
        Ligne = Ligne + 1
        Range("B" & Ligne).Formula = "='" & Filep & "'!toto1"
        Range("C" & Ligne).Formula = "='" & Filep & "'!toto2"
        Range("D" & Ligne).Formula = "='" & Filep & "'!toto3"
        DoEvents
        FilesInPath = Dir()
    Loop
End If
 
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

28/02/2013, 12h06
Thierry360

Merci mercatog !

Si j'ai bien compris "DoEvents" permet d'attendre la fin de l'exécution du code au lieu de laisser le programme planter automatiquement au bout de x secondes ?

Cela semble très bien marcher effectivement.

En revanche l'utilisateur a un curseur de souris « classique » s’affiche.
Y a-t-il un moyen visuel efficace pour indiquer que le programme est bien en train d’agir ?

Je pensais à remplir une cellule avec un texte « Programme en cours » au début du code et à supprimer son contenu à la fin du code.

Ajoute au début

Code:

1
2
3
4
5
6
7
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .Cursor = xlWait
    .StatusBar = "En cours de traitement...."
End With

Et à la fin

Code:

1
2
3
4
5
6
7
8
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .Cursor = xlDefault
    .StatusBar = False
End With
MsgBox "Traitement terminé"

28/02/2013, 14h11
Thierry360

Parfait !
Merci encore !