XL 2016 Filtre auto VBA

[MickaeL_D]

Bonjour à tous,

Le code ci-dessous est placé dans un module que je viens exécuter à l'aide d'un bouton.
Je rencontre un problème lorsque je veux réactiver les filtres auto en fin de code. Car, ils se réactivent au bout de la 2e exécution...

Auriez-vous une solution svp

Sub Ajout_feuil()

Dim ligne As Long, Lg As Long, Lg1 As Long, Lg2 As Long, Lg3 As Long

    'Enlever mdp
    ActiveSheet.Unprotect "2230"
    
    If Worksheets("FENC").FilterMode Then Worksheets("FENC").ShowAllData
    
    'Ajouter une feuille à la fin de votre classeur
    Sheets.Add after:=Sheets(Sheets.Count)
    
    'Copier les colonne A, AH, AI et AJ dans cette nouvelle feuille
    Lg = Sheets("FENC").Range("A2").End(xlDown).Row
    Sheets("FENC").Range("A2:A" & Lg).Copy Destination:=Sheets(Sheets.Count).Range("A1")
    Sheets("FENC").Range("AH2:AH" & Lg).Copy Destination:=Sheets(Sheets.Count).Range("B1")
    Sheets("FENC").Range("AI2:AI" & Lg).Copy Destination:=Sheets(Sheets.Count).Range("C1")
    Sheets("FENC").Range("AJ2:AJ" & Lg).Copy Destination:=Sheets(Sheets.Count).Range("D1")
    
    ' Tri des données dans la feuille créée
    ActiveWorkbook.Worksheets(Sheets.Count).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(Sheets.Count).Sort.SortFields.Add Key:=Range( _
        "B1:B100000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets(Sheets.Count).Sort.SortFields.Add Key:=Range( _
        "C1:C100000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets(Sheets.Count).Sort.SortFields.Add Key:=Range( _
        "D1:D100000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets(Sheets.Count).Sort
        .SetRange Range("A1:D100000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'Supprimer les données des colonnes AH, AI et AJ dans le tableau FENC
    Worksheets("FENC").Range("AH2:AJ" & Lg).ClearContents
    
    'Actualiser votre tableau
    'ActiveWorkbook.RefreshAll
    
    'Remettre en place les données sauvegardées
    Worksheets(Sheets.Count).Select
    ligne = 1
    While Cells(ligne, 2).Value <> "" Or Cells(ligne, 3).Value <> "" Or Cells(ligne, 4).Value <> ""
                Application.StatusBar = "numéro de ligne traitée " & ligne
                Lg = 0
                On Error Resume Next
                Lg = Application.WorksheetFunction.Match(Cells(ligne, 1).Value, Sheets("FENC").Columns("A"), 0)
                On Error GoTo 0
                If Lg <> 0 Then
                               Sheets("FENC").Cells(Lg, 34).Value = Cells(ligne, 2).Value
                               Sheets("FENC").Cells(Lg, 35).Value = Cells(ligne, 3).Value
                               Sheets("FENC").Cells(Lg, 36).Value = Cells(ligne, 4).Value
                End If
                ligne = ligne + 1
    Wend

                Application.StatusBar = False

    'suppression de la feuille et évite l'affichage du message de demande de confirmation de la suppression
        Application.DisplayAlerts = False
        Sheets(Sheets.Count).Delete
        Application.DisplayAlerts = True

    'Se positionner sur la feuille FENC
    Sheets("FENC").Select

    'Tout Actualiser
    ActiveWorkbook.RefreshAll

    'Supprimer les données des colonnes AK, AL et AM dans le tableau FENC
    Lg1 = Sheets("FENC").Range("AK3").End(xlDown).Row
    Worksheets("FENC").Range("AK3:AM" & Lg1).ClearContents

    'Copier formule cellule AK2 dans la colonne AK
    Lg1 = Sheets("FENC").Range("AK3").End(xlDown).Row
    Range("AK2").Select
    Selection.Copy
    Range("AK3:AK" & Lg1).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
     Application.CutCopyMode = False
    
     'Copier formule cellule AL2 dans la colonne AL
    Lg2 = Sheets("FENC").Range("AL3").End(xlDown).Row
    Range("AL2").Select
    Selection.Copy
    Range("AL3:AL" & Lg2).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
     Application.CutCopyMode = False

    'Copier formule cellule AM2 dans la colonne AM
    Lg3 = Sheets("FENC").Range("AM3").End(xlDown).Row
    Range("AM2").Select
    Selection.Copy
    Range("AM3:AM" & Lg3).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
     Application.CutCopyMode = False

    'Activer filtre auto 1ère ligne
    Range("A1").AutoFilter

    'Ajuster hauteur première ligne
    Rows("1:1").RowHeight = 45
    
    'Ajuster largeur première colonne
    Columns("A").ColumnWidth = 12
    Columns("AJ").ColumnWidth = 60
    
    'Remettre mdp
    ActiveSheet.Protect "2230", AllowSorting:=True, AllowFiltering:=True
          
End Sub

 

[cp4]

Bonjour,

Joins ton fichier sans données confidentielles. Fais une copie de ton fichier et rends anonyme toutes les données sensibles.

Évite d'utiliser Select et selection, car ralentissent le code inutilement.

A+

 

[don_pets]

Hello,

Tu peux aussi simplement essayer cela

If Not ActiveSheet.AutoFilterMode Then
    ActiveSheet.Range("A1").AutoFilter
End If

Ju

 

[MickaeL_D]

Merci don_pets,

j'ai ajouté cette ligne à mon code et ça fonctionne.

 ActiveSheet.ListObjects("FENC").ShowAutoFilterDropDown = True