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

M

matamata

XLDnaute Nouveau
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.
 

Pièces jointes

  • Year - 2005.xlsm
    27.4 KB · Affichages: 7
Dernière édition:
Trier par date Trier par votes
Gégé-45550

Gégé-45550

XLDnaute Accro
matamata à dit:
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.
Cliquez pour agrandir...
Bonjour,
à tester :
VB: 
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,
 
Vote positif 0 Vote négatif
Gégé-45550

Gégé-45550

XLDnaute Accro
matamata à dit:
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
Cliquez pour agrandir...
Bonsoir,
J'étais juste allé un peu trop vite
VB: 
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,
 
Vote positif 0 Vote négatif
M

matamata

XLDnaute Nouveau
Gégé-45550 à dit:
Bonsoir,
J'étais juste allé un peu trop vite
VB: 
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,
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif

Discussions similaires

A
  • Résolu(e)
XL 2016 Passer d'une MFC à une macro pour supprimer le bazar dans les règles.
2 3
Réponses
42
Affichages
1 K
TooFatBoy
TooFatBoy
D
  • Question
Microsoft 365 Couper Coller Fichiers en VBA
Réponses
3
Affichages
727
patricktoulon
patricktoulon
R
  • Question
Microsoft 365 problème incompatibilité de type 13 sur macro "couper - coller"
Réponses
6
Affichages
322
rh.finances
R
A
  • Résolu(e)
XL 2016 Transfert de formule d'une feuille à une autre.
Réponses
2
Affichages
414
Al1_44
A
A
  • Résolu(e)
XL 2016 Plage de données fixes pour calcul dans formule
Réponses
3
Affichages
353
sylvanu
sylvanu
R
  • Question
Microsoft 365 Post à supprimer (Fonction Filtre sur plage dejà filtrée)
Réponses
1
Affichages
422
raf26
R
D
  • Question
Microsoft 365 Créer un TOP 20 dynamique avec regroupement
Réponses
3
Affichages
354
chris
chris
H
  • Résolu(e)
Microsoft 365 Packing list automatisée
Réponses
10
Affichages
747
HugoLaChips
H
V
  • Question
XL pour MAC outil coller le contenu du presse papier
Réponses
2
Affichages
548
Valter
V
T
  • Question
Microsoft 365 Coller dans une colonne filtrée
Réponses
5
Affichages
940
bitissa
B

Membres actuellement en ligne

8 membres et 96 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 095
Messages
2 116 167
Membres
112 675
dernier inscrit
Tazra_IMOU