Copier/Inserer le résultat d'un filtre

Bonjour,
Il faut mettre un point avant "[_filterdatabase]".
Cordialement.
Daniel

Bonsoir à tous,

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

'---------------------------------
Sub Test_filter()
Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
Dim Clgn As Long
Dim Rng As Range

Application.ScreenUpdating = False
Set WS1 = Worksheets("Base")
Set WS2 = Worksheets("Semaine")

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")

End With
Set Rng = [_filterdatabase].Resize(, 6).SpecialCells(xlCellTypeVisible)
Clgn = [_filterdatabase].Resize(,
1).SpecialCells(xlCellTypeVisible).Count - 1 'MsgBox "Clgn = " & Clgn
If Clgn > 0 Then
Rng.Copy
With WS2
.Range(.[A10], .[G10].End(xlDown)).Delete shift:=xlUp
.Range("A10").insert shift:=xlDown ',
CopyOrigin:=xlFormatFromLeftOrAbove .[F8].Value = "Semaine du " &
date_debut & " au " & date_fin 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'inserer dans la deuxième feuille (WS2) !

Une correction possible ?

Merci d'avance.

Bonjour Daniel,

L'ajout d'un point n'a rien changé :

Set Rng = .[_filterdatabase].Resize(, 6).SpecialCells(xlCellTypeVisible)

Bon voila le fichier exemple et tu peux voir l'extraction dans les deux feu ille "Semaine" et "Insp" :

http://cjoint.com/?BEslPiacapZ

Bonjour,

Pour cette section, à compléter si tu désires copier le résultat
du filtre vers la plage de destination. Voir la fin de la procédure!

'-----------------------------------
With WS1
If .AutoFilterMode = False Then
With .Range("A7:F7").CurrentRegion
.AutoFilter Field:=3, Criteria1:=">=" & _
date_debut * 1 _
, Operator:=xlAnd, _
Criteria2:="<=" & date_fin * 1

With .Offset(1).Resize(.Rows.Count - 1, 6).SpecialCells(xlCellTypeVisible)
If .Count > 0 Then
'si tu veux copier le résultat du filtre
.Copy 'NomFeuille + première cellule de la plage.
End If
End With
End With
End If
'-----------------------------------

If .Count > 0 Then

On devrait lire :

If .Rows.Count > 0 Then

Ca passe maintenant.

If .Count > 0 Then

On devrait lire :

If .Rows.Count > 0 Then

Mais reste que les lignes copiées ne sont pas insérées !

| Mais reste que les lignes copiées ne sont pas insérées !

Comme je le disais précédemment, tu dois compléter le code :

Tu dois indiquer le nom de la feuille et de la première cellule où la copie
doit s'effectuer. Dans l'exemple suivant, j'ai supposé que la copie devait
se faire à partir de la cellule A1 de la feuille "Feuil1"

'-----------------------
With .Offset(1).Resize(.Rows.Count - 1, 6).SpecialCells(xlCellTypeVisible)
If .Count > 0 Then
'si tu veux copier le résultat du filtre
.Copy Worksheets("Feuil1").Range("A1") ' <<<<==== End If
End With
'-----------------------

Bonjour Denis,

Voila un code qui marche (j'aimerais savoir s'il y a mieux à faire) :

'---------------------------
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
Dim RngIns1 As Range, RngIns2 As Range, RngIns3 As Range, RngIns4 As Ra nge

Application.ScreenUpdating = False

Set WS1 = Worksheets("Base")
Set WS2 = Worksheets("Semaine")
Set WS3 = Worksheets("Insp")

''-----------------------------
'-- Nommage des plages à supprimer avant collage ("Semaine" et "Insp" )
With WS2
If Len(.[A10].Offset(1, 0)) > 0 Then
.Range(.[A10].Address, .[F10].End(xlDown).Address).Name = .Na me
Else
Range(.[A10], .[F10]).Name = .Name
End If
End With
With WS3
If Len(.[A2].Offset(1, 0)) > 0 Then
.Range(.[A2].Address, .[D2].End(xlDown).Address).Name = .Name
Else
Range(.[A2], .[D2]).Name = .Name
End If
End With
''-------------------------------

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
With .Range("A7:F7").CurrentRegion
.AutoFilter Field:=3, Criteria1:=">=" & _
date_debut * 1 _
, Operator:=xlAnd, _
Criteria2:="<=" & date_fin * 1

If Intersect(Range("_FilterDatabase").Cells, _
Range("_FilterDatabase").SpecialCells(xlCellTy peVisible)).Address _
= "$A$7:$F$7" Then
MsgBox ("no results")
WS1.ShowAllData
WS1.AutoFilterMode = False
Exit Sub
Else
'Set Rng = [_filterdatabase].Resize(, 6).SpecialCells (xlCellTypeVisible)
Set Rng = .Offset(1).Resize(.Rows.Count - 1, 6).Speci alCells(xlCellTypeVisible)
Clgn = Rng.Rows.Count
End If
With Rng

If Clgn > 0 Then

'-- Extration des données dans la feuille "Semain e"
With WS2
[Semaine].Delete Shift:=xlUp
.Range("A10").Resize(Clgn, 6).insert Shift:=x lDown
Rng.Copy .Range("A10")
.[E8].Value = "Semaine du " & date_debut & " au " & date_fin
End With

'-- Extration des données dans la feuille "Insp"
'-- seulement les colonnes A, E, C et F dans ce cla ssement
With WS3
Set Rng_Insp = Union(Rng.Columns(1), Rng.Colu mns(5), Rng.Columns(3), Rng.Columns(6))

Clgn = Rng_Insp.Rows.Count
[Insp].Delete Shift:=xlUp
.Range("A2").Resize(Clgn, 4).insert Shift:=xl Down

Rng_Insp.Copy .Range("A2")
End With

On Error Resume Next
WS1.ShowAllData
On Error GoTo 0
End If
End With
End With
End If
End With
'-----------------------------------

Set WS1 = Nothing: Set WS2 = Nothing: Set WS3 = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

'---------------------------

Salut,

Voila un code qui marche (j'aimerais savoir s'il y a mieux à faire) :

Pas de remarques enregistrées.

Et bien, merci.

Salutations.