XL 2016 filtre avec critère ou extraite

[Seddiki_adz]

bonsoir tous
je demande l'aide de mes expert pour extraire les données du BDD une fois pour feuil2 suivant le critère le Nom (colonne 4) et en feuil3 suivant le critère SB le dernier colonne
Merci d'avance

 

[job75]

Bonsoir Seddiki_adz,

Il suffit d'utiliser le filtre avancé, voyez le fichier joint.

Le code de Feuil2 :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D3]) Is Nothing Then Exit Sub
Dim destination As Range, critere As Range
[D3].Select
Set destination = [A7:G7]
Application.ScreenUpdating = False
destination.Offset(1).Resize(Rows.Count - destination.Row).Clear 'RAZ
With Sheets("BDD").[A6].CurrentRegion
    Set critere = .Cells(1, .Columns.Count + 2).Resize(2)
    critere = Application.Transpose([C3:D3])
    If critere(2) = "" Then critere(2) = "#N/A"
    .AdvancedFilter xlFilterCopy, critere, destination 'filtre avancé copié
    critere = ""
End With
End Sub

Le code de Feuil3 :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E3]) Is Nothing Then Exit Sub
Dim destination As Range, critere As Range
[E3].Select
Set destination = [A6:E6]
Application.ScreenUpdating = False
destination.Offset(1).Resize(Rows.Count - destination.Row).Clear 'RAZ
With Sheets("BDD").[A6].CurrentRegion
    Set critere = .Cells(1, .Columns.Count + 2).Resize(2)
    critere = Application.Transpose([D3:E3])
    If critere(2) = "" Then critere(2) = "#N/A"
    .AdvancedFilter xlFilterCopy, critere, destination 'filtre avancé copié
    critere = ""
End With
End Sub

A+

 

[Seddiki_adz]

Bonsoir Seddiki_adz,

Il suffit d'utiliser le filtre avancé, voyez le fichier joint.

Le code de Feuil2 :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D3]) Is Nothing Then Exit Sub
Dim destination As Range, critere As Range
[D3].Select
Set destination = [A7:G7]
Application.ScreenUpdating = False
destination.Offset(1).Resize(Rows.Count - destination.Row).Clear 'RAZ
With Sheets("BDD").[A6].CurrentRegion
    Set critere = .Cells(1, .Columns.Count + 2).Resize(2)
    critere = Application.Transpose([C3:D3])
    If critere(2) = "" Then critere(2) = "#N/A"
    .AdvancedFilter xlFilterCopy, critere, destination 'filtre avancé copié
    critere = ""
End With
End Sub

Le code de Feuil3 :

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E3]) Is Nothing Then Exit Sub
Dim destination As Range, critere As Range
[E3].Select
Set destination = [A6:E6]
Application.ScreenUpdating = False
destination.Offset(1).Resize(Rows.Count - destination.Row).Clear 'RAZ
With Sheets("BDD").[A6].CurrentRegion
    Set critere = .Cells(1, .Columns.Count + 2).Resize(2)
    critere = Application.Transpose([D3:E3])
    If critere(2) = "" Then critere(2) = "#N/A"
    .AdvancedFilter xlFilterCopy, critere, destination 'filtre avancé copié
    critere = ""
End With
End Sub

A+

Merci
très excellent methode