Bonjour à tous,

Je vous sollicite une nouvelle fois car j'ai besoins de votre aide pour résoudre un petit problème.

J'ai crée un code qui copie les données d'une feuille ("Test") par rapport à la date du jour vers une autre feuille (CopieTest).

Mais voilà, j'aurais aimé que ce code copie le contenu de l'ensemble des feuilles par rapport à la semaine en cour.
C'est à dire que actuellement nous sommes semaine 27, et j'aurai aimé copier le contenu des feuilles du 02-07-2012, 03-07-2012, 04-07-2012, 05-07-2012, 06-07-2012.

Vous trouverez ci-joint les fichiers pour cette exemple et ci-dessous les lignes de code.
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
30
31
32
33
34
35
36
37
38
39
40
41
42
Option Explicit
Sub Copie()
 
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
Dim ligne As Long
Dim I As Integer
 
Application.ScreenUpdating = False
Chemin = "C:\CopieTest.xlsx"
If Dir(Chemin) <> "" Then
    Set Wbk = Workbooks.Open(Filename:=Chemin, UpdateLinks:=False)
 
    With Wbk.Worksheets(1)
 
    ligne = .Cells(.Rows.Count, "A").End(xlUp).Row      'supprime les données du jour
      For I = ligne To 1 Step -1
      If Cells(I, 1).Value = Date Then
       Cells(I, 1).EntireRow.Delete
    End If
 
    Next I
 
        For Each Ws In ThisWorkbook.Worksheets      'copie les données du jour
 
            If Ws.Name = Format(Date, "dd-mm-yyyy") Then    'recherche les onglets avec la date du jour
               ligne = Ws.Range("A" & Range("A:A").Rows.Count).End(xlUp).Row
                Ws.Range("A1:B" & ligne).Copy
                .Range("A1").Insert Shift:=xlDown
 
                End If
        Next Ws
    End With
 
    'Wbk.Close True
    Set Wbk = Nothing
 
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub
Test.xlsx
CopieTest.xlsx

Merci beaucoup pour votre aide.

Bonne journée