Bonsoir à tous,

Pour copier ensuite insérer le résultat d'un filtre automatique, j'utilise le code suivant :


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
Sub Test_Filter()
    Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
    Dim Clgn As Long
    Dim Rng As Range, Rng_Insp As Range
 
    Application.ScreenUpdating = False
 
    Set WS1 = Worksheets("Base")
    Set WS2 = Worksheets("Semaine")
    Set WS3 = Worksheets("Insp")
 
    Application.EnableEvents = False
    date_debut = Date - Application.Choose(Application.Weekday(Date, 1), 4, 5, 6, 0, 1, 2, 3)
    date_fin = date_debut + 6
    With WS1
        If .AutoFilterMode = False Then .Range("A7:F7").AutoFilter
        .Range("A7:F7").AutoFilter Field:=3, Criteria1:=">=" & Format(date_debut, "0") _
                                 , Operator:=xlAnd, Criteria2:="<=" & Format(date_fin, "0")
 
        Set Rng = .[_filterdatabase].Resize(, 6).SpecialCells(xlCellTypeVisible)
        Clgn = .[_filterdatabase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count - 1
        MsgBox "Clgn = " & Clgn
 
    End With
 
    If Clgn > 0 Then
        Rng.Copy
        '-- Extration des données dans la feuille "Semaine"
        With WS2
            .Range(.[A10], .[G10].End(xlDown)).Delete shift:=xlUp
            .Range("A10").insert shift:=xlDown    ', CopyOrigin:=xlFormatFromLeftOrAbove
            .[E8].Value = "Semaine du " & date_debut & " au " & date_fin
        End With
 
        '-- Extration des données dans la feuille "Insp"
        With WS3
            Rng_Insp = Union(Rng.Column(1), Rng.Column(5), Rng.Column(3), Rng.Column(6))
            Rng_Insp.Copy
            .Range(.[A2], .[D2].End(xlDown)).Delete shift:=xlUp
            .Range("A2").insert shift:=xlDown
        End With
 
        On Error Resume Next
        WS1.ShowAllData
        On Error GoTo 0
    End If
 
    Set WS1 = Nothing: Set WS2 = Nothing
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Mais voila je n'ai rien d'insérer dans la deuxième et troisième feuille (WS2, WS3) !

Une correction possible ?

Merci d'avance.