Aide sur filtre automatique dans macro ?

Bonjour à tous,

Quelqu'un pourrait m'aider en modifiant ce code svp ?

    Sub MacroAnnulation()
        ActiveSheet.Unprotect "6464"
        Dim LastLig As Long
        Dim cDest As Range
        Application.ScreenUpdating = False
        'cDest: La celllule de destination: première cellule vide de la colonne A de Annulations
       With Worksheets("Annulations")
            Set cDest = .Cells(.Rows.Count, "A").End(xlUp)(2)
        End With
        With ActiveSheet
            'Enlève l'éventuel filtre automatique
           .AutoFilterMode = False
            'LastLig, ligne de la dernière cellule remplie de colonne A de Janvier
           LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
            'On fait un filtre automatique sur la colonne A de Janvier avec comme critère "annulé"
           .Range("A2:A" & LastLig).AutoFilter field:=1, Criteria1:="annulé"
            'Si au moins une ligne résultat du filtre (en plus de la ligne 1 des titres)
           If .Range("A2:A" & LastLig).SpecialCells(xlCellTypeVisible).Count > 1 Then
                With .Range("A3:AQ" & LastLig).SpecialCells(xlCellTypeVisible)
                    'On copie toutes les lignes visibles vers cDest (sauf la ligne des titres)
                   .Copy cDest
                   ActiveSheet.AutoFilterMode = False
                    'on supprime toutes les lignes visibles (sauf la ligne des titres)
                   .Delete xlShiftUp
                End With
            End If
        End With
        Application.ScreenUpdating = True
        ActiveSheet.Protect "6464", True, True, True
    End Sub

En gros, voici le fonctionnement par étape de cette macro (que j'avais trouvé sur le net et que j'avais adapté avec l'aide des forumeurs)

1. désactivation de la protection de la feuille

2. activation du filtre automatique sur la colonne A

3. copie les lignes dont le critère recherché en colonne A est trouvé puis les envois sur une autre feuille

4. désactivation du filtre automatique

5. suppression sur la feuille d'origine, des lignes qui ont été copiées sur l'autre feuille.

6. réactivation de la protection de la feuille

Je l'utilise avec satisfaction depuis un moment, mais désormais je ne vais plus être le seul à me servir de se fichier et je viens de me rendre compte de 2 cas de figure problématiques.

A. Si j'active la macro et que le critère recherché par le filtre automatique dans la colonne A, ne s'y trouve pas, et que RIEN d'autre ne s'y trouve voila ce qu'il se passe : la macro se lance comme il faut..

1. elle désactive la protection de la feuille

2. elle active le filtre automatique

3. réactive la protection de la feuille et se termine avant de désactiver le filtre automatique ..

Deuxième cas.

B. Si j'active la macro et que le critère recherché par le filtre automatique dans la colonne A, ne s'y trouve pas, mais que autre chose s'y trouve,, cela m'affiche le message d'erreur suivant..

erreur d'exécution "6" : Dépassement de capacité

Lorsque je clic alors sur débogage, il pointe sur cette ligne du code :

If .Range("A2:A" & LastLig).SpecialCells(xlCellTypeVisible).Count > 1 Then

Lorsque je quitte le débogage, je dois alors désactiver le filtre manuellement afin que mon cadre réapparaisse

Résultat, dans les 2 cas de figure, cela fait disparaître mon cadre et rend le fichier inutilisable par quelqu'un d'autre que moi.

Je pense que le soucis doit venir du filtre automatique, mais je n'en suis pas certain et suis bien incapable d'y remédier.

Est-ce qu'une âme charitable pourrait m'aider à solutionner ce problème et m'arranger cela s'il vous plais ??

(je vous joint un fichier test si cela peut aider.)

Merci d'avance

Bonjour,

A tester.

Cdlt.

Option Explicit
Option Private Module

Public Sub MacroAnnulation()
Dim ws As Worksheet, ws2 As Worksheet
Dim rCell As Range, rng As Range, rng2 As Range

    Application.ScreenUpdating = False

    Set ws = ActiveSheet
    Set ws2 = ActiveWorkbook.Worksheets("Annulations")
    Set rCell = ws2.Cells(Rows.Count, "A").End(xlUp)(2)

    With ws
        .Unprotect "6464"
        .AutoFilterMode = False
        .[A2].AutoFilter field:=1, Criteria1:="annulé"
        With .AutoFilter.Range
            On Error Resume Next
            Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                      .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With
        If rng Is Nothing Then
            MsgBox "Il n'y a pas de données à copier.", vbInformation
            .AutoFilterMode = False
        Else
            Set rng2 = ActiveSheet.AutoFilter.Range
            rng2.Offset(1, 0).Resize(rng2.Rows.Count - 1).Copy Destination:=rCell
            .AutoFilterMode = False
            rng.EntireRow.Delete xlShiftUp
        End If
        .Protect Password:="6464", _
                 DrawingObjects:=True, _
                 Contents:=True, _
                 Scenarios:=True, _
                 UserInterfaceOnly:=True, _
                 AllowFiltering:=True
    End With

    Set rng2 = Nothing: Set rng = Nothing: Set rCell = Nothing
    Set ws2 = Nothing: Set ws = Nothing

End Sub

Bonjour Jean-Eric,

Merci pour ton temps, ton aide et ta contribution.

Cette modification fonctionne parfaitement, c'est vraiment super !

Un tout grand merci, vraiment !

Edit :

je me suis avancé un peu vite, car il y a un petit soucis que je n'avais pas remarqué..

il faudrait que la copie et suppression de ligne se fasse jusqu'à la cellule de la colonne AQ (incluse) et pas sur la ligne entière.

Pourrais-tu m'arranger cela ?

Bonjour,

A tester.

Cdlt.

Option Explicit
Option Private Module

Public Sub MacroAnnulation()
Dim ws As Worksheet, ws2 As Worksheet
Dim rCell As Range, rng As Range, rng2 As Range

    Application.ScreenUpdating = False

    Set ws = ActiveSheet
    Set ws2 = ActiveWorkbook.Worksheets("Annulations")
    Set rCell = ws2.Cells(Rows.Count, "A").End(xlUp)(2)

    With ws
        .Unprotect "6464"
        .AutoFilterMode = False
        .[A2].AutoFilter field:=1, Criteria1:="annulé"
        With .AutoFilter.Range
            On Error Resume Next
            Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 43) _
                      .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With
        If rng Is Nothing Then
            MsgBox "Il n'y a pas de données à copier.", vbInformation
            .AutoFilterMode = False
        Else
            Set rng2 = ActiveSheet.AutoFilter.Range
            rng2.Offset(1, 0).Resize(rng2.Rows.Count - 1).Copy Destination:=rCell
            .AutoFilterMode = False
           rng.Delete xlShiftUp
        End If
        .Protect Password:="6464", _
                 DrawingObjects:=True, _
                 Contents:=True, _
                 Scenarios:=True, _
                 UserInterfaceOnly:=True, _
                 AllowFiltering:=True
    End With

    Set rng2 = Nothing: Set rng = Nothing: Set rCell = Nothing
    Set ws2 = Nothing: Set ws = Nothing

End Sub