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

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

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