Ma macro met plus d'1 heure pour traiter 9000 fichiers

Bonjour à tous,
Je viens demander de l'aide concernant une macro qui met plus d'1 heure pour traiter 9000 fichiers excel. Je vous explique ce que fait cette macro.

Le processus est le suivant : ouvrir chaque fichier du répertoire, copier le contenu des cellules B2, C2, E1 et le contenu de toutes les cellules fusionnées et les coller dans le fichier source. La macro doit faire ce traitement pour l'ensemble des fichiers contenus dans le répertoire. Tout fonctionne parfaitement comme je le souhaite, le seul problème est que le temps de traitement est trop trop long. Je voulais savoir si quelqu'un aura une autre façon de faire pour réduire le temps de traitement.

Merci d'avance

bonjour

Je voulais savoir si quelqu'un aura une autre façon de faire pour réduire le temps de traitement.

difficile de proposer une autre façon si on ne connait pas la façon utilisée, ni ce qu'il faut faire précisément. Donc merci de lire les recommandations avant de mettre un message, de fournir le minimum d'info qui permet de comprendre ce que tu veux faire (classeur avec la macro, quelques fichiers et les instructions précises concernant ce qu'il y a à copier).

Bonjour h2so4,

Merci pour votre intervention, je pourrai envoyer mon code ou mon fichier?

Voila la partie du code qui le traitement:

Sub ChoixRepertoire()
Dim Repertoire, LeNomF, tmpStr() As String
Dim Fichiers, Fichiers1 As String
Dim n, n1 As String
Dim Cell As Range, adres As String, Plage As Range
Dim lig, NbFichier, NbFichierDepart As Integer, MaHauteur As Single
Dim TempsDebut, TempsFin, TempsComp1, TempsComp2 As Date

Set BoiteDialog = Application.FileDialog(msoFileDialogFolderPicker)
With BoiteDialog
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
End If
Repertoire = .SelectedItems(1) & "\"
End With

Fichiers1 = Dir(Repertoire)

Do Until Fichiers1 = ""
NbFichier = NbFichier + 1
Fichiers1 = Dir
Loop
NbFichierDepart = 0
ThisWorkbook.Sheets("Accueil").Range("G9") = NbFichier
NbFichierDepart = NbFichier
ThisWorkbook.Sheets("Accueil").Range("D10") = 0

Fichiers = Dir(Repertoire)
ThisWorkbook.Sheets("Accueil").Range("D11") = CalculTempsAvecSeconde

Application.ScreenUpdating = False
With Application
.Calculation = xlManual
End With
Do While Len(Fichiers) > 0
Workbooks.Open Filename:=Repertoire & Fichiers
Set WB1 = ActiveWorkbook
Set ws1 = WB1.ActiveSheet
TotLignes = ws1.Range("A" & Rows.Count).End(xlUp).Row

RLines = ws0.Range("A" & Rows.Count).End(xlUp).Row + 1
Set Plage = Range("A1:A" & TotLignes)
For Each Cell In Plage
If Cell.MergeCells = True Then
adres = Cell.Address
ws0.Range("A" & RLines) = ws1.Range("B2")
ws0.Range("B" & RLines) = ws1.Range("E1")
ws0.Range("C" & RLines) = ws1.Range(Cell.Address).Value
ws0.Range("D" & RLines) = ws1.Range("C2")
RLines = RLines + 1
ElseIf adres <> "" And Cell.MergeCells = False Then
'Exit For
End If
Next

WB1.Close SaveChanges:=False
NbFichier = NbFichier - 1
Application.ScreenUpdating = True

With Application
.Calculation = xlAutomatic
End With
ThisWorkbook.Sheets("Accueil").Range("D9") = NbFichier
ThisWorkbook.Sheets("Accueil").Range("D10") = NbFichierDepart - NbFichier
Fichiers = Dir()
ThisWorkbook.Sheets("Accueil").Range("G11") = CalculTempsAvecSeconde
Application.ScreenUpdating = False
Application.CutCopyMode = False
Loop

ThisWorkbook.Sheets("Accueil").Range("G11") = CalculTempsAvecSeconde
Application.ScreenUpdating = True
With Application
.Calculation = xlAutomatic
End With
ws0.Range("A1").AutoFilter field:=2

End Sub

Bonjour Darrylslogen, H2so4,

Mise à part faire le traitement à 2 h du matin le Dimanche du changement d'heure d'Hiver.

Ou effectivement à 2h et quelques minutes ce programme prendrait seulement quelques minutes.

Le temps de traitement est long parce que tu navigues entre 9000 fichiers et un fichier de récup. de données. Donc environ 1/3 de seconde par fichier.

Il serait préférable d'agir en prévention sur chaque fichier concerné avec une feuille Synthèse (Tableau de report) des cellules fusionnées contenues.

Afin que le fichier de récup ne mouline pas entre celles-ci pour les rechercher.

Et sans doute passer par des fichiers de report intermédiaire. 1 pour 100, soit 90 fichiers maîtres dont la tâche (en mode automatisé et en période creuse) serait de récupérer les données de 100 fichiers cibles. Un fichier global n'interviendrait, n'ouvrirait et fermerait que les 90 fichiers de synthèse.

Et ainsi un temps réduit à moins d'une minute. Le travail aurait été fait en amont pendant que tu t'occupes autrement.

adres = Cell.Address
ws0.Range("A" & RLines) = ws1.Range("B2")
ws0.Range("B" & RLines) = ws1.Range("E1")
ws0.Range("C" & RLines) = ws1.Range(Cell.Address).Value
ws0.Range("D" & RLines) = ws1.Range("C2")
RLines = RLines + 1
ElseIf adres <> "" And Cell.MergeCells = False Then
'Exit For

Enfin pourquoi répéter Cell.Address alors que tu as plus haut en 1ière ligne ci-dessus adres.?

Et cette ligne ElseIf ?

Bonjour X Cellus ,

Je te remercie d'avoir pris le temps de me répondre.