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.