Discussion :

[aziz1015]

Bonjour, j'ai un problème avec la copie d'une feuille après un filtre, j'ai utilisé ce programme des centaines de fois, il marche toujours bien, je ne sais pas pourquoi aujourd'hui, cela ne fonctionne pas !

Ici, le code que j'utilise pour faire le filtre et la copie dans un autre onglet :

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
 
 
Sub Test1211()
 
Dim WsSOurce As Worksheet, filtre As Workbook, WsCible As Worksheet
Dim Deb As String, Fin As String
Set WsSOurce = ThisWorkbook.Sheets("Feuil1")
On Error Resume Next: WsSOurce.ShowAllData: On Error GoTo 0
Application.ScreenUpdating = False
Set WsCible = ThisWorkbook.Sheets.Add(After:=WsSOurce)
        Deb = ">" & Year(Date) - 1 & "/12/31"
        Fin = "<" & Format(Date, "yyyy/mm/01")
        WsCible.Name = "tarifé qsdqsd " & Year(Date)
        Set filtre = Workbooks.Add
        filtre.Sheets(1).Range("A1") = "Risque"
        filtre.Sheets(1).Range("B1") = "Risque"
        filtre.Sheets(1).Range("C1") = "Date de fin"
        filtre.Sheets(1).Range("D1") = "Date de fin"
'        filtre.Sheets(1).Range("D1") = "Statut_Etude"
'        filtre.Sheets(1).Range("E1") = "Statut_Etude"
 
        filtre.Sheets(1).Range("A2") = "=SANTE"
        filtre.Sheets(1).Range("B2") = "=PREVOYANCE"
        filtre.Sheets(1).Range("C2") = Deb
        filtre.Sheets(1).Range("D2") = Fin
'        filtre.Sheets(1).Range("D2") = ">2"
'        filtre.Sheets(1).Range("E2") = "<7"
        FiltreActif WsSOurce.UsedRange, filtre.Sheets(1).UsedRange, WsCible.Range("A1")
        filtre.Close False
        Set filtre = Nothing
        Application.ScreenUpdating = True
End Sub
Function FiltreActif(RangeSource As Range, CriterRange As Range, CopyRange As Range, Optional Unique As Boolean = True) As Boolean
FiltreActif = False
On Error Resume Next
 RangeSource.AdvancedFilter Action:= _
        xlFilterCopy, CriteriaRange:=CriterRange _
        , CopyToRange:=CopyRange, Unique:=Unique
        DoEvents
        If Err = 0 Then FiltreActif = True
        'MsgBox Err.Description
        On Error GoTo 0
End Function

Comme vous pouvez le constater sur l'imprim écran, la copie ne se fait que sur la première ligne de l'onglet, les autres données ne sont pas copiées, je ne comprends pas pourquoi !

:

En vous remerciant d'avance pour votre aide