Re : Filtrer des données et supprimer le reste
Bonjour
Voici du code qui réalise le job; à toi de l'adapter à la configuration de ta feuille
Sub FiltreAutoperso()
'1-FILTRER SUR LE CONTENU D UNE CELLULE DANS UNE COLONNE FLA 30.10.07
'2-OPTION 1:COLORIER LES LIGNES VISIBLES
'3-option 2:COPIER LES LIGNES VISIBLES VERS UNE AUTRE FEUILLE
'4-option 2:COPIER LES LIGNES VISIBLES VERS UNE AUTRE FEUILLE
'SUPPRIMER LES LIGNES FILTREES DE LA FEUILLE SOURCE
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim K&, Nbcol&, Vcol&, Choix&, Nomf As String
Dim Actuel As String, Rgf As Range, Rgt As Range, Plage As Range
Actuel = ActiveCell.Value: Nomf = ActiveSheet.Name
Vcol = ActiveCell.Column
K = Cells(65536, Vcol).End(xlUp).Row
Set Plage = Sheets(Nomf).Range("A1").Offset(1).Resize(K, Columns.Count)
Choix = 3 ' OPTION DU FILTRE
Set Rgt = Worksheets("Feuil2").Cells(Rows.Count, 1).End(xlUp) _
.Offset(1, 0)
Cells(1, Vcol).Select
Selection.AutoFilter
With Sheets(Nomf).Cells(1, Vcol)
.AutoFilter field:=Vcol, Criteria1:=Actuel
Set Rgf = Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
Rows.Count - 1).SpecialCells(xlCellTypeVisible)
Select Case Choix
Case Is = 1 'marquage le résultat du filtre dans la feuille source
Rgf.Interior.ColorIndex = 36
Case Is = 2 'copie le résultat du filtre vers autre feuille
Rgf.Copy Destination:=Rgt
Case Is = 3 'garde uniquementle résultat du filtre dans la feuille destination
'et Purge le résultat du filtre dans la feuille source
Rgf.Copy Destination:=Rgt
Rgf.ClearContents
End Select
End With
' Suppression du filtre automatique
Selection.AutoFilter
If Choix = 3 Then
Set Plage = Sheets(Nomf).Range("A1").Offset(1).Resize(K, Columns.Count)
Plage.Sort [a1]
End If
Set Rgf = Nothing: Set Rgt = Nothing: Set Plage = Nothing
Application.Calculation = xlCalculationAutomatic
End Sub
Bien cordialement
Flyonets