XL 2016 VBA-couper/coller une plage filtrée

[matamata]

Bonjour à tous, je souhaite améliorer un code récupéré qui me permet de couper et coller les lignes quand il y a un "x" dans la colonne archivage. Mais cela ne fonctionne pas si il y a des filtres un place. Est il possible de modifier ce code pour filtrer par "x", couper/coller la plage filtrée et désactiver tous les filtres. Merci d'avance pour votre aide.

 

[Gégé-45550]

Bonjour à tous, je souhaite améliorer un code récupéré qui me permet de couper et coller les lignes quand il y a un "x" dans la colonne archivage. Mais cela ne fonctionne pas si il y a des filtres un place. Est il possible de modifier ce code pour filtrer par "x", couper/coller la plage filtrée et désactiver tous les filtres. Merci d'avance pour votre aide.

Bonjour,
à tester :

Sub Macro4()
'
' Macro4 Macro
'

Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
Dim w As Worksheet
Dim filterArray()
Dim currentFiltRange As String
Dim col As Integer

    'Suppression des filtres
    Set w = Worksheets("Archive")
    ' 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
    'Traitement des données à copier
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Archive").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("H1:H" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "x" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "x" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
    
'         Restauration des filtres
    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

Cordialement,

 

[matamata]

Merci pour cette réponse rapide,

J'ai une erreur d'execution à cette ligne: Variable de bloc With non définie

currentFiltRange = .Range.Address

Cdlt

 

[Phil69970]

Bonjour à tous

@matamata
Je te propose ce fichier

==> J'ai commenté le code
==> Les lignes marquées sont supprimées après copie

Merci de ton retour

 

[matamata]

Bonjour à tous

@matamata
Je te propose ce fichier

==> J'ai commenté le code
==> Les lignes marquées sont supprimées après copie

Merci de ton retour

Bonsoir,

Eh bien c'est nickel, bien plus que demandé (tous les tests ou mise en forme...).
Un grand merci, en fait c'est facile VBA...

Je marque comme résolu
Cdlt

 

[Phil69970]

@matamata

En principe on valide le post qui correspond à la solution attendu pas son propre post.
Car tu n'as rien trouvé du tout
Merci de rectifier ....

 

[Gégé-45550]

Merci pour cette réponse rapide,

J'ai une erreur d'execution à cette ligne: Variable de bloc With non définie

currentFiltRange = .Range.Address

Cdlt

Bonsoir,
J'étais juste allé un peu trop vite

Sub Macro4()
'
' Macro4 Macro
'

Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
Dim w As Worksheet
Dim filterArray()
Dim currentFiltRange As String
Dim col As Integer

    'Suppression des filtres
    Set w = Worksheets("Sheet1")
    ' Mise en mémoire des filtres
    If w.AutoFilter Is Nothing Then GoTo traitement     'Sauter cette partie s'il n'existe aucun filtre car sinon une erreur est générée
    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 'supprimer cette ligne si Excel 2010
                        End If
                    End If
                End With
            Next f
        End With
    End With
    'Suppression des filtres
    w.AutoFilterMode = False
traitement:
    'Traitement des données à copier
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Archive").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("H1:H" & I)
    On Error Resume Next
'    Application.ScreenUpdating = False
    For K = xRg.Count To 1 Step -1         'Ce traitement doit commencer par le bas et non par le haut
        Debug.Print xRg(K)
        If UCase(CStr(xRg(K).Value)) = UCase("x") Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
'            If CStr(xRg(K).Value) = "x" Then
'                K = K - 1
'            End If
            J = J + 1
        End If
    Next
'    Application.ScreenUpdating = True
    Worksheets("Archive").Rows.EntireRow.Hidden = False
   If w.AutoFilter Is Nothing Then Exit Sub     'Sortir car le traitement est terminé s'il n'existe aucun filtre
    
'         Restauration des filtres
    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

Cordialement,

 

[matamata]

Bonsoir,
J'étais juste allé un peu trop vite

Sub Macro4()
'
' Macro4 Macro
'

Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
Dim w As Worksheet
Dim filterArray()
Dim currentFiltRange As String
Dim col As Integer

    'Suppression des filtres
    Set w = Worksheets("Sheet1")
    ' Mise en mémoire des filtres
    If w.AutoFilter Is Nothing Then GoTo traitement     'Sauter cette partie s'il n'existe aucun filtre car sinon une erreur est générée
    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 'supprimer cette ligne si Excel 2010
                        End If
                    End If
                End With
            Next f
        End With
    End With
    'Suppression des filtres
    w.AutoFilterMode = False
traitement:
    'Traitement des données à copier
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Archive").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("H1:H" & I)
    On Error Resume Next
'    Application.ScreenUpdating = False
    For K = xRg.Count To 1 Step -1         'Ce traitement doit commencer par le bas et non par le haut
        Debug.Print xRg(K)
        If UCase(CStr(xRg(K).Value)) = UCase("x") Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
'            If CStr(xRg(K).Value) = "x" Then
'                K = K - 1
'            End If
            J = J + 1
        End If
    Next
'    Application.ScreenUpdating = True
    Worksheets("Archive").Rows.EntireRow.Hidden = False
   If w.AutoFilter Is Nothing Then Exit Sub     'Sortir car le traitement est terminé s'il n'existe aucun filtre
   
'         Restauration des filtres
    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

Cordialement,

Bonjour,

Merci beaucoup pour le boulot effectué, ça fonctionne parfaitement. Il faut maintenant que je décode tout ça pour apprendre petit à petit.
Je retiens la solution de Phil69970 car plus complète.
Cordialement.