Discussion :

[apt]

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.

[Daniel.C]

Bonjour,

Il y a plusieurs problèmes. Quand tu éxécute :

Code :

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

.Range(.[A10], .[G10].End(xlDown)).Delete shift:=xlUp

la copie s'efface. Ensuite, la plage copiée ne s'insère pas si les zones la composant ne sont pas continues. Je te propose :

Code :

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

1
2
3
4
5
6
        With WS2
            .Range(.[A10], .[G10].End(xlDown)).Delete shift:=xlUp
            .Range("A10").Resize(8, 6).Insert shift:=xlDown   ', CopyOrigin:=xlFormatFromLeftOrAbove
            Rng.Copy .Range("A10")
            .[E8].Value = "Semaine du " & date_debut & " au " & date_fin
        End With

Je n'ai pas regardé plus loin sauf que tu as une erreur de compilation ici :

Code :

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

Rng_Insp = Union(Rng.Column(1), Rng.Column(5), Rng.Column(3), Rng.Column(6))

où il faut mettre des "s à "Column".

[apt]

Bonsoir Daniel,

Maintenant il y a bien insertion de lignes copiées, mais le "Resize" des lignes pour laisser de la place aux lignes insérées m'efface du texte fixe au dessous du tableau et qui ne doit pas être supprimé !

[Daniel.C]

Oups,

Code :

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

.Range("A10").Resize(Clgn + 1, 6).Insert shift:=xlDown   ', CopyOrigin:=xlFormatFromLeftOrAbove

[apt]

Salut Daniel,

Ça continue encore à supprimer le texte en bas

Voila l'exemple en pièce jointe.

Bonjour,

C'est cette ligne, qui efface le texte en bas :

Code :

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

.Range(.[A10], .[G10].End(xlDown)).Delete Shift:=xlUp

Pourtant il y a bien un espace entre le bas du tableau et le texte à conserver

[Daniel.C]

Bonjour,

Oui, mais elle était dans le code d'origine ? Si elle te gênait, tu aurais dû t'apercevoir que non seulement le collage ne se faisait pas, mais que les données étaient effacées, non ?