Discussion :

[Philippe Tulliez]

Bonjour,
D'où la seconde option

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]

Je l'ai ajouté et je note aucune modification, toujours le même temps pour l'exécution : 1 min

Merci.

Cordialement.

[Daniel.C]

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

[Philippe Tulliez]

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

[manu900]

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é

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

Merci pour tout.

Bonne soirée

Cordialement.

[Daniel.C]

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

[manu900]

Bonjour Daniel, tout fonctionne à la perfection.

Merci, merci, et merci pour tout.
Très bonne journée, à bientôt

Cordialement.