XL 2016 Déplacer Une Ligne Entière Vers Une Autre Feuille En Fonction De La Valeur De La Cellule

[loic59120]

Bonjour à tous,

j'ai une macro qui marche très bien pour déplacer une ligne complète sur une autre feuille mias j'ai un souci il me copie pas la ligne au debut du tableau.
Avez vous une astuce.
ci dessous le code
Merci d'avance Loïc
Sub Cheezy()

Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Commandes").UsedRange.Rows.Count
J = Worksheets("CDES EXPEDIEES").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("CDES EXPEDIEES").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Commandes").Range("G1:G" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "CDE EXPEDIEE" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("CDES EXPEDIEES").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "CDE EXPEDIEE" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub

 

[Robert]

Bonjour Loïc et bienvenu, bonjour le forum,

Si j'ai bien compris, essaie comme ça :

Sub Macro1()
Dim OC As Worksheet 'déclare la variable OC (Onglet Commandes)
Dim OE As Worksheet 'déclare la variable OE (Onglet cmd Expediees)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Long 'déclare la variable I (Incrément)

Set OC = Worksheets("Commandes") 'définit l'onglet OC
Set OE = Worksheets("CDES EXPEDIEES") 'définit l'onglet OE
TV = OC.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs (en partant de la seconde. la première devrait être la ligne d'en-tête)
    If TV(I, 7) = "CDE EXPEDIEE" Then 'condition 'si la donnée ligne I colonne 7 (=> colonne G) est égale à "CDE EXPEDIEE"
        OC.Rows(I).Copy 'copie la ligne I de l'onglet OC
        OE.Rows(1).Insert 'insère la ligne copiée dans la première ligne de l'onglet OE
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
OE.Activate 'active l'onglet OE
Application.CutCopyMode = False 'masque le clignotement des cellules lié au [copier]
End Sub

 

[job75]

Bonsoir loik59120, Robert,

En utilisant le filtre automatique :

Sub Cheezy()
Dim dest As Range
With Sheets("CDES EXPEDIEES")
    If .FilterMode Then .ShowAllData
    Set dest = .Cells(.Cells(.Rows.Count, 7).End(xlUp).Row + 1, 1)
End With
Application.ScreenUpdating = False
With Sheets("Commandes")
    If Application.CountIf(.Columns(7), "CDE EXPEDIEE") Then
        With .Range("A1", .UsedRange.EntireRow)
            .AutoFilter 7, "CDE EXPEDIEE" 'filtre automatique
            With Intersect(.Offset(1), .Cells)
                .Copy dest
                .SpecialCells(xlCellTypeVisible).Delete 'supprime les lignes copiées
            End With
            .AutoFilter 'ôte le filtre
        End With
    End If
    If Application.CountA(dest(0).EntireRow) = 0 Then .Rows(1).Copy dest(0) 'ligne des titres
End With
End Sub

A+

 

[job75]

Mais la macro précédente peut être très lente s'il y a un grand nombre de lignes filtrées disjointes.

Pour aller vite il faut cette macro qui utilise une colonne auxiliaire et un tri :

Sub Cheezy2()
Dim dest As Range
With Sheets("CDES EXPEDIEES")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set dest = .Cells(.Cells(.Rows.Count, 7).End(xlUp).Row + 1, 1)
End With
Application.ScreenUpdating = False
With Sheets("Commandes")
    If Application.CountIf(.Columns(7), "CDE EXPEDIEE") Then
        With .Range("A1", .UsedRange)
            .Columns(7).EntireColumn.Insert 'insère une colonne auxiliaire
            .Columns(7) = "=1/(RC[1]=""CDE EXPEDIEE"")/(ROW()>1)" 'formule du filtrage
            .Columns(7) = .Columns(7).Value 'supprime les formules
            .Sort .Columns(7), xlDescending, Header:=xlYes 'tri pour regrouper et accélérer
            With .Columns(7).SpecialCells(xlCellTypeConstants, 1).EntireRow
                .Copy dest
                .Delete 'supprime les lignes copiées
            End With
            dest(1, 7).Resize(Rows.Count - dest.Row + 1).Delete xlToLeft
            .Columns(7).EntireColumn.Delete 'supprime la colonne auxiliaire
        End With
    End If
    If Application.CountA(dest(0).EntireRow) = 0 Then .Rows(1).Copy dest(0) 'ligne des titres
End With
End Sub

 

[loic59120]

Bonjour,
Merci ca marche parfaitement

 

[loic59120]

j'ai juste un souci,
il me supprime la colonne G dans la feuilles dans cdes expédiées du coup
le tableaux ne correspond plus

 

[job75]

Bonjour loic59120,

Oui j'ai fait une erreur.

Dans la macro du post #4 je viens de remplacer :

dest(1, 7).EntireColumn.Delete

par :

dest(1, 7).Resize(Rows.Count - dest.Row + 1).Delete xlToLeft

A+

 

[loic59120]

Bonjour job75

Merci beaucoup