XL 2016 Filtre auto VBA

MickaeL_D

XLDnaute Junior
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


VB:
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

XLDnaute Barbatruc
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+
 

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
313 322
Messages
2 097 141
Membres
106 850
dernier inscrit
benbeckman