Fonction date semaine

Version imprimable

Voir 40 message(s) de cette discussion en une page

2 pièce(s) jointe(s)

Fonction date semaine

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:

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
Pièce jointe 98220
Pièce jointe 98221

Merci beaucoup pour votre aide.

Bonne journée

Bonjour,

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

Code:

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

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:

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

03/07/2012, 13h16
Daniel.C

Citation:

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:

For I = 1 To 5

par :

Code:

For I = 5 To 1
03/07/2012, 13h53
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.
03/07/2012, 15h04
fring

Citation:

Envoyé par Daniel.C

Code:

For I = 5 To 1

Bonjour,

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

Code:

For I = 5 To 1 Step -1
03/07/2012, 15h09
manu900

Bonjour fring,

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

Merci

Cordialement
03/07/2012, 15h16
fring

Citation:

Envoyé par manu900

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.
03/07/2012, 15h41
Daniel.C

@ fring : le rouge me monte au front ;)

Comme le suggère fring, corrige :

Code:

For I = 5 To 1 Step -1

au lieu de :

Code:

For I = 5 To 1
04/07/2012, 09h50
manu900

Bonjour Daniel,

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

Merci.

Cordialement

Bonjour,

Essaie comme ça :

Code:

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

04/07/2012, 12h43
manu900

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

Code:

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

Citation:

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

Merci encore Daniel

cordialement
04/07/2012, 15h19
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.
05/07/2012, 09h56
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.

Teste cette macro :

Code:

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

05/07/2012, 13h22
manu900

Merci beaucoup Daniel, cela fonctionne parfaitement.

Puis-je te poser une dernière question?

Merci encore, bonne après-midi

Cordialement
05/07/2012, 17h55
Daniel.C

Citation:

Puis-je te poser une dernière question?

Mais oui !

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:

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.

06/07/2012, 09h15
Philippe Tulliez
Bonjour,
Pour supprimer en une instruction plusieurs lignes.

Code:

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:

1 2 3 4 5 Application.ScreenUpdating = False ' Boucle + Instructions ...... ..... Application.ScreenUpdating = True
06/07/2012, 11h19
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.

Voir 40 message(s) de cette discussion en une page