Discussion :

[manu900]

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

[Daniel.C]

Bonjour,

Je n'ai testé que la partie "date" :

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
43
Sub Copie()
 
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
Dim ligne As Long
Dim I As Integer
Dim JourSem 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
 
        JourSem = Application.Weekday(Date, 2)
        For Each Ws In ThisWorkbook.Worksheets      'copie les données du jour
            For I = 1 To 5
                If Ws.Name = Format(Date - JourSem + I, "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 I
        Next Ws
    End With
 
    'Wbk.Close True
    Set Wbk = Nothing
 
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub

[manu900]

Bonjour Daniel.C,

Merci beaucoup pour ta réponse, cela fonctionne parfaitement. J'ai également réussi la fonction "date".
Toutefois, je voulais savoir si il était possible que la copie des données se fasse de façon décroissante, c'est à dire la date la plus grande jusqu'a la plus petite.
De plus, que signie le chiffre "2" sur cette ligne de code : JourSem = Application.Weekday(Date, 2)

Pour ceux que cela intéresse, voici la ligne de code avec la fonction "date"

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
43
44
45
46
47
48
49
Option Explicit
Sub Copie()
 
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
Dim ligne As Long
Dim I As Integer
Dim N As Integer
Dim JourSem 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)
    JourSem = Application.Weekday(Date, 2)
    ligne = .Cells(.Rows.Count, "A").End(xlUp).Row      'supprime les données du jour
      For I = ligne To 1 Step -1
        For N = 1 To 5
          If Cells(I, 1).Value = Date - JourSem + N Then
       Cells(I, 1).EntireRow.Delete
    End If
     Next N
    Next I
 
 
        JourSem = Application.Weekday(Date, 2)
        For Each Ws In ThisWorkbook.Worksheets      'copie les données du jour
            For I = 1 To 5
            If Ws.Name = Format(Date - JourSem + I, "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 I
        Next Ws
    End With
 
    'Wbk.Close True
    Set Wbk = Nothing
 
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub

Merci encore Daniel.

Cordialement

[Daniel.C]

De plus, que signie le chiffre "2" sur cette ligne de code : JourSem = Application.Weekday(Date, 2)

"WeekDay" est la transcription VBA de la fonction Excel JOURSEM. Le paramètre "2" signifie que le premier jour de la semaine est le lundi.
Sinon, pour avoir les feuilles du vendredi au lundi, remplace :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For I = 1 To 5

par :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For I = 5 To 1

[manu900]

Merci Daniel pour la précision sur le "Weekday".

Cela ne fonctionne pas en modifiant la ligne :

For I = 5 to 1

Rien ne ce copie sur la feuille copie test.

Merci

Cordialement.

[fring]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For I = 5 To 1

Bonjour,

Dans ce cas il faut préciser le "pas"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For I = 5 To 1 Step -1

[manu900]

Bonjour fring,

Sa ne marche pas non plus, les dates sont toujours dans l'ordre croissant.

Merci

Cordialement

[fring]

Sa ne marche pas non plus, les dates sont toujours dans l'ordre croissant.

Je ne répondais pas à ton problème mais je précisais à Daniel que lorsqu'on veut faire une boucle allant du plus grand au plus petit il faut préciser le pas de décrémentation.

[Daniel.C]

@ fring : le rouge me monte au front

Comme le suggère fring, corrige :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For I = 5 To 1 Step -1

au lieu de :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For I = 5 To 1

[manu900]

Bonjour Daniel,

La modif n'a rien changé, j'ai toujors les dates classées par ordre croissant.

Merci.

Cordialement

[Daniel.C]

Bonjour,

Essaie comme ça :

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
Sub Copie()
 
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
Dim ligne As Long
Dim I As Integer
Dim JourSem As Integer
 
Application.ScreenUpdating = False
Chemin = "C:\CopieTest.xlsx"
If Dir(Chemin) <> "" Then
    Set Wbk = Workbooks.Open(Filename:=Chemin, UpdateLinks:=False)
 Set Wbk = ActiveWorkbook
    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
 
        JourSem = Application.Weekday(Date, 2)
 
        For I = 1 To 5
            Set Ws = ThisWorkbook.Worksheets(Format(Date - JourSem + I, "dd-mm-yyyy"))   '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
        Next I
 
    'Wbk.Close True
    Set Wbk = Nothing
 End With
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub

[manu900]

Cela copie correctement les dates par ordre croissant mais ensuite j'ai un message d'erreur sur cette ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set Ws = ThisWorkbook.Worksheets(Format(Date - JourSem + I, "dd-mm-yyyy"))

Erreur d'exécution 9 : l'indice n'appartient pas à la sélection

Merci encore Daniel

cordialement

[Daniel.C]

La macro suppose qu'il y a un onglet par jour ouvré de la semaine. Si ce n'est pas toujours vrai, je peux adapter.

[manu900]

Bonjour Daniel,

Effectivement, il y a que 5 onglets pour 5 jours. De plus, il est possible d'avoir que 4 ou 3 jours à cause des jours fériés.

Merci.

Cordialement.

[Daniel.C]

Teste cette macro :

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
43
Sub Copie()
 
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
Dim ligne As Long
Dim I As Integer
Dim JourSem As Integer
 
Application.ScreenUpdating = False
Chemin = "C:\CopieTest.xlsx"
If Dir(Chemin) <> "" Then
    Set Wbk = Workbooks.Open(Filename:=Chemin, UpdateLinks:=False)
 Set Wbk = ActiveWorkbook
    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
 
        JourSem = Application.Weekday(Date, 2)
 
        On Error Resume Next
        For I = 1 To 5
 
            Set Ws = ThisWorkbook.Worksheets(Format(Date - JourSem + I, "dd-mm-yyyy"))   '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
        Next I
        On Error GoTo 0
 
    'Wbk.Close True
    Set Wbk = Nothing
 End With
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub

[manu900]

Merci beaucoup Daniel, cela fonctionne parfaitement.

Puis-je te poser une dernière question?

Merci encore, bonne après-midi

Cordialement

[Daniel.C]

Puis-je te poser une dernière question?

Mais oui !

[manu900]

Bonjour Daniel,

La dernière question concerne l'opération "supprimer date."

Comme vous avez pu le constater, le programme est une sorte de mise à jour des données de la semaine en cour. En effet je supprime les données déja enregistrées pour inscrir les nouvelles.

Mais voilà, dans mon fichier original, j'ai énormément de dates (classées par ordre décroissant), donc, la fonction "supprimer date" prend énormément de temps à se réaliser puisque c'est une boucle.

Je souhaite donc savoir si il est possible de modifier le début du programme afin que cette opération soit rapide. Pour information, les dates de la semaine en cour à supprimer se situe dans les 400 premières lignes.

Voici à ce stade le code du programme.

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
43
44
45
46
47
Option Explicit
Sub Copie()
 
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim Chemin As String
Dim ligne As Long
Dim I As Integer
Dim N As Integer
Dim JourSem 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)                              ''supprime les données des dates de la semaine
    JourSem = Application.Weekday(Date, 2)
    ligne = .Cells(.Rows.Count, "A").End(xlUp).Row
      For I = ligne To 1 Step -1
        For N = 1 To 5
          If Cells(I, 1).Value = Date - JourSem + N Then
       Cells(I, 1).EntireRow.Delete
    End If
     Next N
    Next I
 
 JourSem = Application.Weekday(Date, 2)
 
        On Error Resume Next                'copie les données de la semaine
        For I = 1 To 5
 
            Set Ws = ThisWorkbook.Worksheets(Format(Date - JourSem + I, "dd-mm-yyyy"))
               ligne = Ws.Range("A" & Range("A:A").Rows.Count).End(xlUp).Row
                Ws.Range("A1:B" & ligne).Copy
                .Range("A1").Insert Shift:=xlDown
        Next I
        On Error GoTo 0
 
    'Wbk.Close True
    Set Wbk = Nothing
 End With
Else
    MsgBox "Fichier " & Chemin & " inexistant"
End If
End Sub

Merci pour ta réponse.

Cordialement.

[Philippe Tulliez]

Bonjour,
Pour supprimer en une instruction plusieurs lignes.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 Range("A4:A24").EntireRow.Delete

Ceci dit supprimer plusieurs lignes dans une boucle peut être accéléré en utilisant l'instruction Application.ScreenUpdating

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Application.ScreenUpdating = False
 ' Boucle + Instructions
 ......
 .....
Application.ScreenUpdating = True

[manu900]

Bonjour Corona,

Le problème de faire une instruction sur plusieurs ligne c'est que cela me supprime des lignes que je ne souhaite pas. En effet, je souhaite supprimer un ensemble de ligne dont les cellules contiennent les dates de la semaine en cours.

Merci.

Cordialement.