Philippe Tulliez
Ce que l'on conçoit bien s'énonce clairement, et les mots pour le dire arrivent aisément. (Nicolas Boileau)
Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer suret si celle-ci est pertinente pensez à voter
Mes tutoriels : Utilisation de l'assistant « Insertion de fonction », Les filtres avancés ou élaborés dans Excel
Mon dernier billet : Utilisation de la fonction Dir en VBA pour vérifier l'existence d'un fichier
Je l'ai ajouté et je note aucune modification, toujours le même temps pour l'exécution : 1 min
Merci.
Cordialement.
Bonjour,
Ce code ajoute temporairement une ligne d'entête, filtre les données sur la date du jour et supprime les lignes correspondantes :
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
50
51
52
53
54 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) .Rows(1).Insert .[A1] = "bidon" .AutoFilterMode = False Set plage = .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp)) plage.AutoFilter 1, Format(Date, "dd/mm/yyyy") Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1) If Application.Subtotal(103, plage) > 0 Then Set plage = plage.SpecialCells(xlCellTypeVisible) plage.EntireRow.Delete .AutoFilterMode = False .Rows(1).Delete End If ' 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
Bonjour,
Désolé, je n'avais pas vu que l'instruction était déjà présente dans le code.
Si des calculs entrent en ligne de compte, il y a aussi l'instruction éventuellement à ajouter
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5 Application.Calculation = xlCalculationManual ' Code ' ....... Application.Calculation = xlCalculationAutomatic
Philippe Tulliez
Ce que l'on conçoit bien s'énonce clairement, et les mots pour le dire arrivent aisément. (Nicolas Boileau)
Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer suret si celle-ci est pertinente pensez à voter
Mes tutoriels : Utilisation de l'assistant « Insertion de fonction », Les filtres avancés ou élaborés dans Excel
Mon dernier billet : Utilisation de la fonction Dir en VBA pour vérifier l'existence d'un fichier
Merci pour ta réponse Daniel,
Cela fonctionne pour la date du jour, toutefois, j'ai essayé que le filtre s'applique pour tous les jours de la semaine en cours s'en grande réussite. Voici ce que j'a rajouté
Merci pour tout.
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4 For N = 1 To 5 Set plage = .Range([A1], .Cells(.Rows.Count, 1).End(xlUp)) plage.AutoFilter 1, Format(Date - JourSem + N, "dd-mm-yyy") Next N
Bonne soirée
Cordialement.
Essaie :
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 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) JourSem = Application.Weekday(Date, 2) .Rows(1).Insert .[A1] = "bidon" .AutoFilterMode = False Set plage = .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp)) plage.AutoFilter 1, ">=" & Format(Date - JourSem + 1, "mm/dd/yyyy"), xlAnd, _ "<=" & Format(Date - JourSem + 5, "mm/dd/yyyy") Set plage = plage.Offset(1).Resize(plage.Rows.Count - 1) If Application.Subtotal(103, plage) > 0 Then Set plage = plage.SpecialCells(xlCellTypeVisible) plage.EntireRow.Delete .AutoFilterMode = False .Rows(1).Delete End If 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
Bonjour Daniel, tout fonctionne à la perfection.
Merci, merci, et merci pour tout.
Très bonne journée, à bientôt
Cordialement.
Partager