Filtrer et déplacer les cellules visible

Bonjour

J’ai un " tableau1" de "A : J" et la colonne "E" contient des comptes

Je souhaite faire une macro qui filtre chaque compte et déplacé le résultat vers un nouveau feuil nommer de la valeur filtré

voici mon code

Sub Macro1()
Dim lignes_visibles  As Range
If Sheets("grand livre").Range("E2").Offset(1, 0).Value = 0 Then Exit Sub
ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=5, Criteria1:=Sheets("grand livre").Range("E2").Offset(1, 0).Value
With Sheets("GRAND LIVRE").ListObjects("Tableau1")
        Set lignes_visibles = .DataBodyRange.SpecialCells(xlCellTypeVisible)
        If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
            Sheets.Add
            ActiveSheet.Name = Sheets("grand livre").Range("E2").Offset(1, 0).Value
             lignes_visibles.Copy
         ActiveSheet.Paste
        Cells.EntireColumn.AutoFit
        lignes_visibles.Delete
 End With
Sheets("GRAND LIVRE").Select
End Sub

Svp est ce que j'ai bien rédiger ce code et comment le mettre dans une boucle

Bonjour,

moi, depuis peu j'essaie d'utiliser les filtres avancés d'Excel, ceux ci permettent de faire un filtre tout en copiant le résultat vers une zone, plage, feuille voulue.

Avez vous regardez de ce coté ?

Sinon votre code je ne l'ai pas essayé, mais s'il marche, pour le mettre "en boucle" je suppose que c'est la valeur 5 (qui correspond à une colonne) qui devra évoluer, donc un

For Bcl = 5 to 7

votre code avec le 5 remplacé par la variable Bcl

et un

Next Bcl

vous permettra de "jouer" ce code sur les colonnes 5 - 6 et 7

Enfin disons que l'idée est là

@ bientôt

LouReeD

merci pour votre réponse

voici un fichier démo

Bonsoir iliess, LouReeD

Comme ceci :

Option Explicit
Sub test()
Dim a, e, dico As Object, wsName As String
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    With Sheets("GRAND LIVRE")
        With .Range("a1").CurrentRegion
            With .Offset(1).Resize(.Rows.Count - 1)
                a = .Columns(5).Offset(1).Resize(.Rows.Count - 1).Value
                For Each e In a
                    If Not dico.exists(e) Then
                        dico(e) = Empty
                        wsName = "Compte " & e
                        If Not Evaluate("isref('" & wsName & "'!a1)") Then
                            Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName
                        End If
                        Sheets(wsName).Cells.Delete
                        .AutoFilter 5, e
                        .SpecialCells(xlCellTypeVisible).Copy Sheets(wsName).Cells(1)
                        With Sheets(wsName)
                            'mise en forme eventuelle
                        End With
                        .AutoFilter
                    End If
                Next
            End With
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Propre et rapide votre code

Mille Merci Mr Klin89

Bonjour Mr Klin

j'ai utilisé votre code plus que une année et ça marche très bien et merci beaucoup.

j'ai essayer d'ajouter ou modifier votre code de telle sort que

- si la feuil existe il ajoute le filtre dans cette feuil après la dernière cellule non vide

j'ai modifier cette expression .Cells(1) par Sheets(wsName).Range("A9").End(xlDown).Offset(1, 0) et résultat deux entête dans le fichier

comment copier les ligne visible sans l’entête

voici mon fichier démo

merci beaucoup

Bonsoir iliess

Si j'ai bien compris :

Option Explicit
Sub Filtrer_et_deplacer()
Dim a, e, dico As Object, wsName As String
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    With Sheets("GRAND LIVRE")
        With .Range("a1").CurrentRegion
            With .Offset(1).Resize(.Rows.Count - 1)
                a = .Columns(5).Offset(1).Resize(.Rows.Count - 1).Value
                For Each e In a
                    If Not dico.exists(e) Then
                        dico(e) = Empty
                        wsName = e
                        .AutoFilter 5, e
                        If Not Evaluate("isref('" & wsName & "'!a1)") Then
                            Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName
                            .SpecialCells(xlCellTypeVisible).Copy Sheets(wsName).Range("A9")
                        Else
                            .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets(wsName).Range("a" & .Rows.Count).End(xlUp)(2)
                        End If
                        .AutoFilter
                    End If
                Next
            End With
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour

Mille Merci Monsieur Tu Ma bien compris

Svp une dernier question

je souhaite supprimer tous la ligne qui contient TOTAUX et SOLDE COMPTABLE RECTIFIE et DIFF pour que la nouvelle plage se colle avec l'ancien et ça pour tous les feuil du classeur

voici un image