XL 2016 Déplacer des lignes d'une feuille à l'autre

kalem · 28 Juillet 2020

Bonjour à tous,
Encore une fois, le petit bricoleur excel du dimanche que je suis arrive à ses limites... Voici ma mission : concevoir un fichier d'excel pour gérer des commandes de livres et de mangas, et déplacer ainsi les lignes d'ouvrages en fonction de leur statut indiqué en J (à commander, acquis, rejeté).
Il y a plusieurs feuilles :
- En cours : rassemble les titres qu'on envisage de commander
- Livres : tous les ouvrages à commander (sauf manga) : ce sera une sorte de bon de commande.
- Manga : tous les mangas à commander, là aussi cela fera office de bon de commande
- Acquis : les ouvrages commandés
- Rejetés : ceux dont on a abandonné l'achat.
- Une synthèse qui récapitule les dépenses et offre des boutons d'actions.

En gros, voici ce que je n'arrive pas à paramétrer :
- Un bouton orange qui déplace les lignes de "Livres" et de "Manga" vers "Acquis" (afin d'avoir une feuille vierge pour la commande suivante). Voir ci-dessous.
- Un bouton bleu grâce auquel tous les ouvrages (donc toutes les lignes) marqués comme "à commander" dans la feuille "en cours" soient transférés soit dans la feuille "Livres", soit dans "Manga" (l'information étant dans la colonne A).
Je peux déplacer des lignes d'une feuille à l'autre, mais je n'arrive pas à mettre la condition : si en A="Manga" alors transférer dans "Manga", sinon dans "Livres".
- Avec ce même bouton bleu, que les ouvrages indiqués comme "rejeté" soient déplacés dans la feuille "Rejetés".

Je vous joins ma piètre tentative... Je m'excuse d'avance pour le bazar que j'ai mis dans les modules, j'ai fait n'importe quoi à force de jouer les apprentis sorciers...

Pour le bouton orange et le déplacement du contenu de deux feuilles dans une troisième, j'arrive à le faire sur une, mais pas sur deux :

VB:

Sub Bouton1_QuandClic()
Dim DerL As Long, Lif As Long
With Worksheets("Livres"), -----> ici je voudrais ajouter le contenu de la feuille "Manga"
DerL = .Range("A" & Rows.Count).End(xlUp).Row
For i = DerL To 5 Step -1
    If .Cells(i, 5) <> "" Then
            Lig = Worksheets("Acquis").Range("A" & Rows.Count).End(xlUp).Row + 1
        .Rows(i).Copy Worksheets("Acquis").Range("A" & Lig)
        .Rows(i).Delete
    End If
Next
.Range("A5:I" & DerL).Sort Key1:=.Range("C5"), Order1:=xlAscending, Key2:=.Range( _
"I5"), Order2:=xlAscending, Header:=xlGuess
End With
End Sub

Merci d'avance pour votre aide précieuse !

kalem · 30 Juillet 2020

Bonjour,
Comme je vois que nombreux sont en vacances ici , j'ai essayé d'avancer.... Bon, en ajoutant une colonne masquée K qui affiche "OKMANGA" s'il y a "Manga" en A et "Livres" en J, et en enchaînant les macros dans le même module, ça a l'air de fonctionner. Ce n'est pas propre du tout et je pense qu'il y avait plus simple mais voilà ce que ça donne :

VB:

Sub Deplacer_mangas()

Dim Lig As Long, Col As String
Dim NbrLig As Long, NumLig As Long
Dim xRg As Range
 
Sheets("En cours").Activate
Col = "K"
NumLig = Cells(Rows.Count, 2).End(xlUp).Row
If NumLig < 7 Then NumLig = 6
With Sheets("En cours")
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = 7 To NbrLig
        If .Cells(Lig, Col).Value = "OKMANGA" Then
                 NumLig = NumLig + 1
            .Cells(Lig, Col).EntireRow.Copy Destination:=Sheets("Manga").Cells(NumLig, 1).EntireRow
        End If
    Next
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = NbrLig To 7 Step -1
        If .Cells(Lig, Col).Value = "OKMANGA" Then
            .Cells(Lig, Col).EntireRow.Delete
        End If
    Next
End With
If NumLig >= 7 Then
    Set xRg = Range(Cells(7, "B"), Cells(NumLig, "H"))
    xRg.Sort Key1:=xRg(1, 2), Order1:=xlAscending, Header:=xlNo, _
                Key2:=xRg(1, 1), Order2:=xlAscending
End If
Call Deplacer_livres
End Sub
Sub Deplacer_livres()

Dim Lig As Long, Col As String
Dim NbrLig As Long, NumLig As Long
Dim xRg As Range
 
Sheets("En cours").Activate
Col = "K"
NumLig = Cells(Rows.Count, 2).End(xlUp).Row
If NumLig < 7 Then NumLig = 6
With Sheets("En cours")
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = 7 To NbrLig
        If .Cells(Lig, Col).Value = "OKLIVRE" Then
            NumLig = NumLig + 1
            .Cells(Lig, Col).EntireRow.Copy Destination:=Sheets("Livres").Cells(NumLig, 1).EntireRow
        End If
    Next
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = NbrLig To 7 Step -1
        If .Cells(Lig, Col).Value = "OKLIVRE" Then
            .Cells(Lig, Col).EntireRow.Delete
        End If
    Next
End With
If NumLig >= 7 Then
    Set xRg = Range(Cells(7, "B"), Cells(NumLig, "H"))
    xRg.Sort Key1:=xRg(1, 2), Order1:=xlAscending, Header:=xlNo, _
                Key2:=xRg(1, 1), Order2:=xlAscending
End If
Call Deplacer_rejets
End Sub
Sub Deplacer_rejets()

Dim Lig As Long, Col As String
Dim NbrLig As Long, NumLig As Long
Dim xRg As Range
 
Sheets("En cours").Activate
Col = "J"
NumLig = Cells(Rows.Count, 2).End(xlUp).Row
If NumLig < 7 Then NumLig = 6
With Sheets("En cours")
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = 7 To NbrLig
        If .Cells(Lig, Col).Value = "Rejeté" Then
            NumLig = NumLig + 1
            .Cells(Lig, Col).EntireRow.Copy Destination:=Sheets("Rejetés").Cells(NumLig, 1).EntireRow
        End If
    Next
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = NbrLig To 7 Step -1
        If .Cells(Lig, Col).Value = "Rejeté" Then
            .Cells(Lig, Col).EntireRow.Delete
        End If
    Next
End With
If NumLig >= 7 Then
    Set xRg = Range(Cells(7, "B"), Cells(NumLig, "H"))
    xRg.Sort Key1:=xRg(1, 2), Order1:=xlAscending, Header:=xlNo, _
                Key2:=xRg(1, 1), Order2:=xlAscending
End If
End Sub

Mon seul souci, c'est que j'ai l'impression que certaines lignes déplacées écrasent les précédentes... Bizarre.

kalem · 7 Septembre 2020

Help !!!!
Je n'y comprends rien. J'ai bien l'impression que le fichier fonctionnait fin juillet lors de ma phase de test, mais maintenant que j'essaie d'appliquer, ça ne marche pas ! Voilà ce qui passe : les lignes "à commander" sont bien supprimées de la feuille "en cours" mais ne sont pas copiées dans les autres feuilles de destination...
Est-ce qu'une âme charitable verrait où est le problème...?
Je sais que c'est un peu fastidieux, toutes mes excuses, mais là, je suis vraiment coincé !
Bonne soirée à tous.

kalem · 21 Octobre 2020

Bonjour à tous,
Comme je ne suis pas du genre à lâcher le morceau, après un moment de découragement, je me décide à rouvrir ce fichier...
J'ai compris ce qui ne va pas, ce n'est pas grand chose en fait : toutes les lignes se déplacent comme il faut d'une feuille à l'autre, mais elles ne remontent pas, elles se mettent en bas de la feuille, alors même que des lignes ont été vidées au-dessus...
Quelqu'un pourrait-il m'indiquer comment modifier le code pour qu'elles remontent automatiquement à partir de la première ligne vide ?
Merci d'avance !

VB:

Sub Deplacer_mangas()

Dim Lig As Long, Col As String
Dim NbrLig As Long, NumLig As Long
Dim xRg As Range
  
Sheets("En cours").Activate
Col = "I"
NumLig = Cells(Rows.Count, 2).End(xlUp).Row
If NumLig < 7 Then NumLig = 6
With Sheets("En cours")
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = 7 To NbrLig
        If .Cells(Lig, Col).Value = "OKMANGA" Then
                 NumLig = NumLig + 1
            .Cells(Lig, Col).EntireRow.Copy Destination:=Sheets("Manga").Cells(NumLig, 1).EntireRow
        End If
    Next
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = NbrLig To 7 Step -1
        If .Cells(Lig, Col).Value = "OKMANGA" Then
            .Cells(Lig, Col).EntireRow.Delete
        End If
    Next
End With
If NumLig >= 7 Then
    Set xRg = Range(Cells(7, "B"), Cells(NumLig, "H"))
    xRg.Sort Key1:=xRg(1, 2), Order1:=xlAscending, Header:=xlNo, _
                Key2:=xRg(1, 1), Order2:=xlAscending
End If
Call Deplacer_livres
End Sub
Sub Deplacer_livres()

Dim Lig As Long, Col As String
Dim NbrLig As Long, NumLig As Long
Dim xRg As Range
  
Sheets("En cours").Activate
Col = "I"
NumLig = Cells(Rows.Count, 2).End(xlUp).Row
If NumLig < 7 Then NumLig = 6
With Sheets("En cours")
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = 7 To NbrLig
        If .Cells(Lig, Col).Value = "OKLIVRE" Then
            NumLig = NumLig + 1
            .Cells(Lig, Col).EntireRow.Copy Destination:=Sheets("Livres").Cells(NumLig, 1).EntireRow
        End If
    Next
    NbrLig = .Cells(.Rows.Count, Col).End(xlUp).Row
    For Lig = NbrLig To 7 Step -1
        If .Cells(Lig, Col).Value = "OKLIVRE" Then
            .Cells(Lig, Col).EntireRow.Delete
        End If
    Next
End With
If NumLig >= 7 Then
    Set xRg = Range(Cells(7, "B"), Cells(NumLig, "H"))
    xRg.Sort Key1:=xRg(1, 2), Order1:=xlAscending, Header:=xlNo, _
                Key2:=xRg(1, 1), Order2:=xlAscending
End If
End Sub

XL 2016 Déplacer des lignes d'une feuille à l'autre

kalem

XLDnaute Junior

Pièces jointes

kalem

XLDnaute Junior

kalem

XLDnaute Junior

kalem

XLDnaute Junior

Discussions similaires