Aide VBA historisation

[anthooooony]

Bonjour cher exeldownloadiens,

L'heure est grave ! pour moi, je suis ralenti par un accroissement des mails que je reçois et que je traite.

Après avoir fait(trouvé) une macro outlook qui me met mes fichiers joints dans un dossier, je récupère 4 cellules de chaque fichiers pour les mettre les unes en dessous des autres.

Exemple des éléments que je récupère c'est seulement 4 personnes pour l'exemple mais en réalité j'ai 1616 lignes de prises
18/04/2013 12 Roxanne_53 264
18/04/2013 16 Laurence_505 571
18/04/2013 1 Olivier_(96 294)
18/04/2013 37 Mars_331 423


Je reçois 15 fichiers par jour en moyenne il y a 30.5 jours par mois. En 3.5Mois j'ai à ce jour 1616 fichiers joints.
dans trois mois j'aurai le double 3232 et aujourd'hui je mets 7minutes à faire ma macro dans trois mois j'en mettrai 14 minutes.

Les quatre personnes ci dessus sont sur les fichiers du bas. La date est au milieu -20130418.

Export-20130418-050645612.xls
Export-20130418-050644143.xls
Export-20130418-050642456.xls
Export-20130418-050641113.xls

Le problème que j'ai ,c 'est que lorsque je lance ma macro pour récupérer tous les nouveaux éléments, il les reprend tous à CHAQUE FOIS, au début c'était rapide j'en avais 15, mais au fur et à mesure j'en reçois de plus en plus, et j'en stock de plus en plus la lenteur va avec bien entendu.

Je n'arrive pas à lui dire de ne prendre que les fichiers qui ne sont pas deja copiés dans mon fichiers excel.
Le but étant demain si je lance ma macro il ne prenne que les 15 nouveaux fichiers fraichement arrivés au lieu de prendre les 1616+15..

Merci à vous de votre possible aide


Anthooooony

Ps: Ma commande qui fonctionne mais qui commence à être longue...

Sub aaaaa()

Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual
 sousRépertoire = "Fichiers Retard Relance"
 [A2].CurrentRegion.Offset(1, 0).Clear
 Set maitre = ActiveWorkbook
 Repertoire = ThisWorkbook.Path
 nf = Dir(Repertoire & "\" & sousRépertoire & "\*.xls") ' premier fichier
Do While nf <> ""
 Workbooks.Open Filename:=Repertoire & "\" & sousRépertoire & "\" & nf
With ThisWorkbook.Sheets("Feuil1")
    derlig = .Range("A65000").End(xlUp).Row + 1
   .Range("A" & derlig) = DateSerial((Mid(Cells(1, 1), 18, 4)), (Mid(Cells(1, 1), 15, 2)), (Mid(Cells(1, 1), 12, 2)))
   .Range("B" & derlig) = Left([D7], InStr(1, [D7], " ") - 1)
   .Range("C" & derlig) = LTrim(Split([B3] & " ")(0))
   .Range("D" & derlig) = Application.Sum(Range("j1").EntireColumn) / 2
End With

 ActiveWorkbook.Close False

nf = Dir ' fichier suivant


 Loop
 Application.Calculation = xlCalculationAutomatic
ActiveWorkbook.RefreshAll
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub