Bonjour,

Je possède des rapports journaliers nommés Rapport_du_jj_mm_aaaa.xls qui se trouvent dans un même dossier \test. Chaque jour un rapport est généré et placé dans ce dossier. Ce rapport est composé d'une feuille dont les données qui m'intéressent vont de la cellule A2 à AU2.
Je souhaiterais créer un fichier test.xls unique qui importe à chaque ouverture le dernier fichier ajouté dans ce répertoire.
Actuellement, j'ai une macro qui me permet d'importer tous les fichiers contenus dans le dossier. Le soucis c'est que lorsqu'un nouveau rapport se trouve dans le dossier \test et que j'ouvre test.xls, le nouveau rapport remplace le premier existant alors que je voudrais qu'il s'ajoute à la suite des autres...
Je ne suis pas sûr que ces macros soient vraiment utiles car j'ai essayé de nombreuses façons mais je les fournis quand même.

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
Sub TransfertDonnées()
 
Dim strWB As String
Dim strFile As String
Dim lgDerLig As Long
 
Application.ScreenUpdating = False
Application.EnableEvents = False
 
strWB = ThisWorkbook.Name
strFile = Dir(ThisWorkbook.Path & "\test\*.xls")
lgDerLig = 2
 
Do While strFile <> ""
    If Worksheets("Feuil1").Columns("A").Find(strFile, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
        Workbooks.Open ThisWorkbook.Path & "\test\" & strFile
        ActiveWorkbook.Worksheets(1).Activate
        Worksheets(1).Range("A2:AU2").Copy Destination:=Workbooks(strWB).Worksheets("Feuil1").Range("B" & lgDerLig)
        Workbooks(strWB).Worksheets("Feuil1").Range("A" & lgDerLig) = strFile
        lgDerLig = lgDerLig + 1
        Workbooks(strFile).Close
    End If
strFile = Dir
Loop
 
Application.ScreenUpdating = True
Application.EnableEvents = True
 
End Sub
OU

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
Sub TransfertDonnées()
 
Dim strWB As String
Dim strFile As String
 
Application.ScreenUpdating = False
Application.EnableEvents = False
 
strWB = ThisWorkbook.Name
strFile = Dir(ThisWorkbook.Path & "\test\*.xls")
 
Do While strFile <> ""
If strFile <> strWB And Worksheets("Feuil1").Columns("A").Find(strFile, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
    Workbooks.Open ThisWorkbook.Path & "\test\" & strFile
    Workbooks(strFile).Worksheets(1).Range("A2:AU2").Copy
    With Workbooks(strWB).Worksheets("Feuil1")
        .Range("A2").Insert xlDown
    End With
    Workbooks(strFile).Close
End If
 
strFile = Dir
Loop
 
Application.EnableEvents = True
Application.ScreenUpdating = True
 
End Sub
Toute aide est la bienvenue.
En vous remerciant.