Sauvegarder / restaurer un filtre

Bonjour à tous,

J'utilise actuellement un code permettant de sauvegarder et de restaurer des filtres. Je précise que je ne suis pas l'auteur de ce code, je l'ai récupéré sur un site : Askcodez.

La problématique que je rencontre est que lorsqu'un filtre est appliqué sur une colonne contenant des dates la macro plante. Je suppose que cela provient de la différence de format entre les dates françaises et les dates US.

Si quelqu'un a une idée pour adapter ce code je serais preneur.

Bonne fin de week-end et bonne soirée,

Camille

Sub ReDoAutoFilter()
Dim w As Worksheet
Dim filterArray()
Dim currentFiltRange As String
Dim col As Integer
Set w = ActiveSheet
' Capture AutoFilter settings
With w.AutoFilter
currentFiltRange = .Range.Address
With .Filters
ReDim filterArray(1 To .Count, 1 To 3)
For f = 1 To .Count
With .Item(f)
If .On Then
filterArray(f, 1) = .Criteria1
If .Operator Then
filterArray(f, 2) = .Operator
filterArray(f, 3) = .Criteria2 'simply delete this line to make it work in Excel 2010
End If
End If
End With
Next f
End With
End With
'Remove AutoFilter
w.AutoFilterMode = False
' Your code here
' Restore Filter settings
For col = 1 To UBound(filterArray(), 1)
If Not IsEmpty(filterArray(col, 1)) Then
If filterArray(col, 2) Then
w.Range(currentFiltRange).AutoFilter field:=col, _
Criteria1:=filterArray(col, 1), _
Operator:=filterArray(col, 2), _
Criteria2:=filterArray(col, 3)
Else
w.Range(currentFiltRange).AutoFilter field:=col, _
Criteria1:=filterArray(col, 1)
End If
End If
Next col
End Sub

Bonjour,

Un fichier joint "sans données confidentielles" mais de même structure que le fichier original ainsi qu'une description de ce que vous voulez faire nous aiderait davantage plutôt qu'un code à déchiffrer et sans support.

Cdlt

Bonjour Arturo,

Le code utilisé permet de :

1- Retirer l'intégralité des filtres appliqués sur le fichier source tout en sauvegardant ces filtres.

2- Filtrer sur un compte (le N° de compte est sélectionné au préalable cf. code présent dans le module "Filtre"' => AA= Activecell)

3- Copier toutes les écritures de ce compte dans un nouvel onglet

4- Retourner sur le fichier source et réappliquer les filtres présents initialement.

Le code fonctionne très bien sauf quand un filtre est appliqué sur la colonne date et je ne sais pas comment résoudre ce problème.

J'ajoute le fichier source en PJ (Module = Filtre).

Merci,

Camille

C'est normal que ça ne fonctionne pas, le nom d'un onglet ne peut pas contenir de "/", il faut donc remplacer les "/" de la date par des "_"

ActiveSheet.Name = AA & "#"

Remplacez la ligne suivante par ces 2 ci:

NomFeuille = Replace(AA, "/", "_")
ActiveSheet.Name = NomFeuille

Cdlt

Dans mon utilisation, ActiveCell (Set AA = ActiveCell), sera toujours un compte. Ce sera donc forcément un nombre de 6 à 8 caractères.

Si vous faites du pas à pas, vous verrez que AA est une date.

Arturo, je viens de faire le test en mettant votre partie de code (sur le nom de la feuille).

J'obtiens toujours le bug lorsqu'un filtre est actif sur la colonne EcritureDate.

Bonjour,

Plutôt qu'un code récupérer sur le NET, parce que, peut être pas approprié à ce que vous voulez faire, il serait plus judicieux de décrire la façon dont vous procédez.

- Dans un premier temps, vous appliquez un filtre, mais:

- Sur quelles colonnes s'applique le filtre, est-ce uniquement sur la colonne "CompteNum" ou bien faites-vous des filtres multiples?

- Le nom des feuilles ainsi créées, ne comporte-il que celui du N° de "CompteNum" ou voulez-vous le compléter avec autre chose?

Cdlt

Bonjour,

Oui vous avez raison, je me rends compte que le code utilisé n'est peut être pas adapté.

Le filtre peut effectivement être présent sur plusieurs colonne et cela varie en fonction des besoins.

La feuille créée s'appelle : "N°" + le numéro du compte.

Sur une même colonne il peut y avoir des choix multiples de filtres (exemple sur la colonne Journalib, le journal des achats et le journal de banque peuvent être sélectionnés en même temps). A priori le code utilisé ne permet pas non plus cette utilisation.

Merci,

Camille

Bonjour,

Voici le code:

Sub Sauvegarde_Filtre()
    Dim f1 As Worksheet
    Dim c As Range
    Dim DerLig As Long, NbCol As Long, N°_Compte As Long

    Application.ScreenUpdating = False
    Set f1 = Sheets("FEC")
    DerLig = f1.Range("E" & Rows.Count).End(xlUp).Row
    For Each c In f1.Range("E2:E" & DerLig)
        If Rows(c.Row).Hidden = False Then
            N°_Compte = f1.Cells(c.Row, "E")
            Exit For
        End If
    Next c

    NbCol = f1.Range("A1").End(xlToRight).Column
    f1.Range("_FilterDataBase").Resize(, NbCol).SpecialCells(xlCellTypeVisible).Copy

    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "N°" & N°_Compte
    ActiveSheet.Paste
    f1.ShowAllData
    Set f1 = Nothing
End Sub

dans le fichier joint ci-dessous, appliquez les filtres de votre choix, puis cliquez sur le bouton "Sauvegarde de la zone filtrée"

Cdlt

Arturo,

Toutes les écritures du compte sélectionnées ne sont pas reprise dans la nouvelle feuille créée. J'aimerais que l'intégralité des écritures du fichier ayant ce numéro de compte soient reprises dans la nouvelle feuille créée (et uniquement ces écritures).

Ce code prend la première cellule de la colonne E2 comme N° de compte, j'aurais besoin que ce soit le compte présent dans la cellule active (ce qui me permet de sélectionner le compte souhaité).

J'ai parfois des fichiers avec plusieurs centaines de milliers de lignes, je ne peux pas utiliser une boucle pour faire le copier de valeur (je pense que cela sera trop long à exécuter) c'est pour cela que je pensais au filtre.

Merci pour votre temps,

Camille

Donc dans vos filtres, si j'ai bien compris, , vous pouvez sélectionner plusieurs N° de compte, et c'est celui de la cellule que vous aurez sélectionné ,après filtrage, qui servira de nom de feuille, c'est bien ça?

Si la réponse est "OUI" alors appliquez le code suivant:

Sub Sauvegarde_Filtre()
    Dim f1 As Worksheet
    Dim c As Range
    Dim DerLig As Long, NbCol As Long, N°_Compte As Long

    Application.ScreenUpdating = False
    Set f1 = Sheets("FEC")
    DerLig = f1.Range("E" & Rows.Count).End(xlUp).Row
    If ActiveCell.Column = 5 Then
        N°_Compte = f1.Cells(ActiveCell.Row, "E")
        NbCol = f1.Range("A1").End(xlToRight).Column
        f1.Range("_FilterDataBase").Resize(, NbCol).SpecialCells(xlCellTypeVisible).Copy
        Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "N°" & N°_Compte
        ActiveSheet.Paste
        f1.ShowAllData
    End If
    Set f1 = Nothing
End Sub

Si la réponse est "NON", Il serait bien de citer un exemple des filtres que vous appliquez, on gagnerait du temps et on irait directement à la bonne solution.

Cdlt

Le filtre n'est pas systématiquement sur la colonne CompteNum. Le filtre peut être sur plusieurs colonnes.

Je donne un exemple :

Je filtre sur la colonne JounalLib, colonne dans laquelle je filtre sur les journaux CREDIT AGRICOLE et CREDIT MUTUEL.

Je filtre ensuite sur la colonne EcritureDate, colonne dans laquelle je filtre sur la date du 10/11/2020.

Je sélectionne une cellule contenant le compte N° 625100

J'aimerais ensuite que la macro aille me chercher l'intégralité des écritures du fichier (même celle masquées) contenant le compte 625100 dans la colonne CompteNum et que ces lignes soient collées dans une nouvelle feuille qui portera le nom N°625100. L'opération doit être faite par la macro sans modifier mon affichage actuel.

Ce que je pensais faire c'était :

1- Sauvegarder les filtres en place

2- Retirer les filtres

3- Filtrer sur la colonne Comptenum sur le compte N°625100

4- Copier les ligner et les coller dans une nouvelle feuille

5- Revenir sur la feuille d'origine et réappliquer les filtres présents initialement

ça fonctionne à peu près avec le code que j'ai trouvé sur ASKODEZ mais dès qu'il y a un filtre sur une date ou un filtre sur plusieurs données d'une même colonne ça plante et j'avoue ne pas trouver de solution.

Camille

Bonjour,

Ok je comprends mieux, alors essayez ceci:

Sub Sauvegarde_Filtre()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig As Long, NbCol As Long, N°_Compte As Long

    Application.ScreenUpdating = False
    Set f1 = Sheets("FEC")
    If ActiveCell.Column <> 5 Then
        MsgBox "Veuillez sélectionner un N° de compte"
        Exit Sub
    End If
    With f1.AutoFilter
        DerLig = f1.Range("A1").CurrentRegion.Rows.Count
    End With

    N°_Compte = ActiveCell.Value
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "N°" & N°_Compte
    Set f2 = Sheets(ActiveSheet.Name)
    f1.Range("A1:F1").Copy f2.Range("A1:F1")

    ReDim Tabl(DerLig)
    N = 1
    For Each c In f1.Range("E2:E" & DerLig)
        If c = N°_Compte Then
            Tabl(N) = Array(f1.Cells(c.Row, "A"), f1.Cells(c.Row, "B"), f1.Cells(c.Row, "C"), f1.Cells(c.Row, "D"), f1.Cells(c.Row, "E"), f1.Cells(c.Row, "F"))
            N = N + 1
            NMax = N
        End If
    Next

    N = 1
    For i = 2 To NMax
        Range(f2.Cells(i, "A"), f2.Cells(i, "F")) = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Tabl(N)))
        N = N + 1
    Next i

    f2.Columns("C:C").NumberFormat = "0"
    f2.Cells.EntireColumn.AutoFit
    Set f1 = Nothing
    Set f2 = Nothing
End Sub

Cdlt

Merci ARTURO pour ce code. De prime abord ça fonctionne et ça répond à ce dont j'avais besoin

Je regarde ça plus en détail ce soir.

Camille

En relisant, je viens de m'apercevoir qu'il y a une ligne qui pourrait être simplifiée,

remplacez cette ligne:

Range(f2.Cells(i, "A"), f2.Cells(i, "F")) = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Tabl(N)))

par celle-ci:

Range(f2.Cells(i, "A"), f2.Cells(i, "F")) = Tabl(N)

Cdlt

Merci Arturo,

Je viens de tester la macro sur des fichiers plus conséquents. Pour certains comptes l'exécution est très longue (entre 5 et 10 minutes).

Peut être serait il possible d'accélérer l'exécution en passant par un filtre ?

Camille

Bonjour,

Evidemment de 5 à 10 mn c'est énorme, alors je vous propose une autre façon de procéder.

1) - Dans un premier temps on fait une copie de la feuille "FEC" sans filtre, opération à faire la première seule fois, et à refaire s'il y a eu des modifications du nombre de lignes dans la feuille "FEC", ceci est fait en cliquant sur le bouton vert "Copie de la feuille non filtrée"

2) - Appliquez les filtres de votre choix, cliquez sur le bouton jaune "Sauvegarde de la zone filtrée".

Recommencez l'opération 2 autant de fois que vous le souhaitez.

le fichier

le code:

Sub Sauvegarde_Filtre()
    Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
    Dim DerLig As Long, NbCol As Long, N°_Compte As Long

    Application.ScreenUpdating = False
    Set f1 = Sheets("FEC")
    Set f2 = Sheets("Copie_FEC")
    If ActiveCell.Column <> 5 Then
        MsgBox "Veuillez sélectionner un N° de compte"
        Exit Sub
    End If
    With f1.AutoFilter
        DerLig = f1.Range("A1").CurrentRegion.Rows.Count
    End With

    N°_Compte = ActiveCell.Value
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "N°" & N°_Compte
    Set f3 = Sheets(ActiveSheet.Name)
    f2.Range("A1:F" & DerLig).AutoFilter Field:=5, Criteria1:=N°_Compte
    f2.Range(f2.Cells(1, "A"), f2.Cells(DerLig, "F")).SpecialCells(xlVisible).Copy f3.Range("A1")

    f3.Columns("C:C").NumberFormat = "0"
    f3.Cells.EntireColumn.AutoFit
    f2.AutoFilterMode = False
    f2.Range("A1:F1").AutoFilter
    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
End Sub

Sub Copie_FEC()
    Dim f1 As Worksheet, f2 As Worksheet
    Application.ScreenUpdating = False
    Set f1 = Sheets("FEC")
    Set f2 = Sheets("Copie_FEC")
    f1.AutoFilterMode = False
    f1.Range("A1:F1").AutoFilter
    f2.Cells.ClearContents
    DerLig_f1 = f1.Range("A1").CurrentRegion.Rows.Count
    f1.Range("A1:F" & DerLig_f1).Copy f2.Range("A1")
    f2.Cells.EntireColumn.AutoFit
    f2.Range("A1:F1").AutoFilter
End Sub

Cdlt

Merci beaucoup ARTURO, ça m'a l'air top.

Je vais tester ça.

Camille

Merci ARTURO votre code fonctionne parfaitement pour ce que j'ai besoin de faire.

Admettons désormais que je souhaite filtrer non pas sur un N° de compte mais sur une date. J'ai essayé d'adapter le code, cependant le format de la date ne permet pas de filtrer.

Y a t'il un moyen de convertir le format ?

Merci

Camille

Sub Sauvegarde_Filtre()
    Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
    Dim DerLig As Long, NbCol As Long, EcritureDate As Long

    Application.ScreenUpdating = False
    Set f1 = Sheets("FEC")
    Set f2 = Sheets("Copie_FEC")
    If ActiveCell.Column <> 4 Then
        MsgBox "Veuillez sélectionner une date"
        Exit Sub
    End If
    With f1.AutoFilter
        DerLig = f1.Range("A1").CurrentRegion.Rows.Count
    End With

    EcritureDate = ActiveCell.Value
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = EcritureDate
    Set f3 = Sheets(ActiveSheet.Name)
    f2.Range("A1:F" & DerLig).AutoFilter Field:=4, Criteria1:=EcritureDate
    f2.Range(f2.Cells(1, "A"), f2.Cells(DerLig, "F")).SpecialCells(xlVisible).Copy f3.Range("A1")

    f3.Columns("C:C").NumberFormat = "0"
    f3.Cells.EntireColumn.AutoFit
    f2.AutoFilterMode = False
    f2.Range("A1:F1").AutoFilter
    Set f1 = Nothing
    Set f2 = Nothing
    Set f3 = Nothing
End Sub

Sub Copie_FEC()
    Dim f1 As Worksheet, f2 As Worksheet
    Application.ScreenUpdating = False
    Set f1 = Sheets("FEC")
    Set f2 = Sheets("Copie_FEC")
    f1.AutoFilterMode = False
    f1.Range("A1:F1").AutoFilter
    f2.Cells.ClearContents
    DerLig_f1 = f1.Range("A1").CurrentRegion.Rows.Count
    f1.Range("A1:F" & DerLig_f1).Copy f2.Range("A1")
    f2.Cells.EntireColumn.AutoFit
    f2.Range("A1:F1").AutoFilter
End Sub