Déplacer ligne de données d'un tableau à un autre en fonction d'une liste

re-Bonjour, je croyais avoir trouvé une solution à mon problème ci-dessous mais cela ne fonctionne pas lorsque je suis la démarche expliquée..Je me permets donc cette fois de m'en remettre à vous au cas où quelqu'un puisse m'aider.

J'ai un tableau dans lequel j'ai des "Ordres de travail". Un ordre par ligne, avec numéro, nom de client, détails et finalement le statut; que je choisis en utilisant une petite liste déroulante.

Ce statut peut varier, par exemple "ordre à deviser" ou "devis envoyé" ou "devis validé", le dernier statut possible est par exemple "commande facturée et livrée"

Je souhaiterais que dès qu'une ligne a le statut "commande facturée, livrée" elle disparaisse de mon tableau principal et aille alimenter un tableau secondaire (sur un autre onglet par exemple) afin de ne plus avoir sur mon tableau principal les travaux terminés et livrés et y garder juste ce qui est en attente de validation ou en cours.

J'ai naïvement pensé qu'il devait y avoir une fonction qui me permette de faire sauter un ligne d'un tableau à un autre en fonction d'un choix sur une liste déroulante mais ce n'est pas le cas.

Merci pour votre aide et désolé si ce n'est pas clair...!

Djav.

Ci-dessous la solution de 3GB que j'ai essayé de reproduire sans succès.

Bonjour,

Voici une solution, éventuellement à améliorer, et certainement à adapter avec vos références (j'ai pris les colonnes A à D par défaut d'informations supplémentaires et supposé que vos noms de feuilles étaient A traiter et Fait) :

'DANS UN MODULE NORMAL

Sub ArchiverTraitements(Cible as range)

Dim wsT as worksheet, wsF as worksheet
Dim Lcible as long, NvL as long

Set wsT = Worksheets("A traiter") 'feuille A traiter
Set wsF = Worksheets("Fait") 'feuille Fait
Lcible = Cible.Row 'ligne en cours 'ligne en cours
NvL = wsF.cells(rows.count, 1).end(xlup).row + 1 'nouvelle ligne (dernière + 1) : 1ère cellule vide sur col A de Fait
with wsT.range("A" & Lcible & ":D" & Lcible) 'avec la ligne en cours de A traiter
    .copy destination:=wsF.range("A" & NvL) 'copier/coller sur Fait
    '.entirerow.hidden = true 'masquer
    .delete shift:=xlShiftUp 'suppression vers le haut
end with

msgbox "Traitement et déplacement OK"

End Sub

'DANS LE MODULE DE LA FEUILLE "A traiter"

Private Sub Worksheet_Change(ByVal Target As Range)
If not intersect(Target, range("D:D")) is nothing and not target.count > 1 then 'zone d'application de l'évènement et limite à une cellule
    If not application.countblank(range("A" & target.row & ":D" & target.row)) > 0 then 'continue si aucune cellule vide
        Call ArchiverTraitements(target)
    end if
end if
End sub

Pour y arriver, il faut :

- enregistrer le fichier au format .xlsm,
- activer le volet "Développeur" (si ce n'est pas déjà fait) : Volet "Fichier" / Options / Personnaliser le ruban > cocher "développeur",
- sur le volet "Développeur", ouvrir l'éditeur "Visual Basic" (raccourci Alt + F11),
- dans le menu contextuel "Insertion", sélectionner "Module",
- aller sur ce nouveau module et y copier le premier code,
- aller sur le module de la feuille "A traiter" et y coller le 2nd code.

Ensuite vous pourrez commencer les tests

Cdlt,

Bonjour

Tu devrais joindre ton fichier ou un fichier représentatif et il serait plus facile de te proposer quelque chose ...

Bye !

Salut djav,
Salut 3GB (car il va sûrement arriver...)

je ne trouve pas, dans le code 3GB, une référence au statut provoquant le déplacement de ligne !
Dans cet exemple, inutile de créer de liste de validation via Excel : la macro s'en charge elle-même à condition que la [Axx] soit déjà complétée.

Code à adapter selon les intitulés du fichier réel..

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
If Not Intersect(Target, Columns(4)) Is Nothing And Range("A" & Target.Row).Value <> "" Then _
    Target.Validation.Delete: _
    Target.Validation.Add Type:=xlValidateList, Formula1:="Ordre à deviser,Devis envoyé,Devis validé,Commande facturée et livrée"
'
End Sub

L'instruction Cut a l'avantage de couper et déplacer lorsqu'on précise la destination.

Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim sWk As Worksheet
'
Set sWk = Worksheets("Archives")
Application.EnableEvents = False
'
If Not Intersect(Target, Columns(4)) Is Nothing And Target = "Commande facturée et livrée" Then _
    Range("A" & Target.Row).Resize(1, 4).Cut sWk.Range("A" & sWk.Range("A" & Rows.Count).End(xlUp).Row + 1): _
    sWk.Columns.AutoFit
'
Application.EnableEvents = True
'
End Sub

A+

Salut GMB, fichier ci-joint. les 2 status qui entraînent une sortie du premier tableau pour aller dans le second sont: "Refusé/sortie coffre" et "Livré/sortie coffre".

Salut Curulis57, merci beaucoup pour le fichier! c'est bien ça que je souhaite faire.. je vais essayer d'adapter ton exemple à mon tableau. Par contre est-ce que du coup mes mises en formes conditionnelles peuvent subsister? et y a-t-il une solution "simple" pour ajouter un statut "erreur" pour faire revenir une ligne dans le tableau principal en cas de mauvaise manipulation?

Bonjour à tous,

@djav : Si j'en crois mon commentaire, ce code était un essai à l'aveugle, sans fichier. Il est prévu pour se déclencher suite à une modification en colonne D si les cellules correspondantes en A à C sont bien remplies. Je pense qu'il est préférable de conditionner ça plus assidument

if Cible Like "*sortie coffre" then 'par exemple (si j'ai bien compris)

comme le suggèrent mes camarades.

@Curulis : Salut ! De mémoire, j'avais proposé de couper les lignes mais ça ne convenait pas puisque certaines se trouvaient en plein coeur du tableau, d'où le copy, delete...

Cdlt,

Bonjour 3GB, merci beaucoup pour ta réponse, par contre la ligne que tu proposes est à ajouter au code proposé Curulius57? Si oui où ça? j'ai peur que mes compétences en excel/vba s'arrêtent à peu près là..

Bonjour djav,

Comme je l'ai compris (je n'ai pas regardé le fichier), les critères de sortie sont en colonne D. Si on doit sortir la ligne quand la cellule est modifiée pour valoir "...sortie coffre", alors la condition serait à rajouter après le premier if du code de curulis :

Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim sWk As Worksheet
'
Set sWk = Worksheets("Archives")
Application.EnableEvents = False
'
If Not Intersect(Target, Columns(4)) Is Nothing Then
    if target like "*sortie coffre" then
        Range("A" & Target.Row).Resize(1, 4).Cut sWk.Range("A" & sWk.Range("A" & Rows.Count).End(xlUp).Row + 1)
        'Range("A" & Target.Row).Resize(1, 4).copy sWk.Range("A" & sWk.Range("A" & Rows.Count).End(xlUp).Row + 1) 'au cas où
        'Range("A" & Target.Row).Resize(1, 4).delete xlshiftup       'au cas où
        sWk.Columns.AutoFit
    end if
end if

Application.EnableEvents = True
'
End Sub

Mais maintenant que tu as posté ton fichier, il y a fort à parier que GMB te le retourne solutionné !

Cdlt,

3GB, merci pour les précisions! je vais essayer.

Et si entre temps GMB solutionne le fichier, 2020 aura finalement été plus fructueuse que prévu (ça m'a même donné envie de me plonger dans quelques exercices excel, tuto et autres)

Bonne journée à tous

Salut djav,
Salut 3GB (quand on parle du loup, manque plus que gmb ),

même chose en tenant compte du nouveau fichier.
- j'ai supprimé les listes de validation en [F:F]... et en [G:G] (les mêmes !!!) d'autant que leurs formules ne correspondaient pas ;
- la liste de validation se crée à la demande et tiendra compte des mises à jour de cette liste en [J:J]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
If Not Intersect(Target, Columns(6)) Is Nothing And Range("A" & Target.Row).Value <> "" Then _
    Target.Validation.Delete: _
    Target.Validation.Add Type:=xlValidateList, Formula1:="=J2:J" & Range("J" & Rows.Count).End(xlUp).Row
'
End Sub

- j'ai supprimé les MFC : la macro s'en charge.

Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim sWk As Worksheet, iRow%, iCol%
'
Set sWk = Worksheets("Sortie")
Application.EnableEvents = False
'
If Not Intersect(Target, Columns(6)) Is Nothing And Target <> "" Then _
    iRow = Target.Row: _
    iCol = Cells(1, 1).End(xlToRight).Column: _
    Range("A" & iRow).Resize(1, iCol).Font.Color = Columns(10).Find(what:=Target, lookat:=xlWhole, LookIn:=xlValues).Font.Color: _
    Range("A" & iRow).Resize(1, iCol).Interior.Color = Columns(10).Find(what:=Target, lookat:=xlWhole, LookIn:=xlValues).Interior.Color: _
    If InStr(Target, "sortie coffre") > 0 Then _
        Range("A" & Target.Row).Resize(1, iCol).Copy Destination:=sWk.Range("A" & sWk.Range("A" & Rows.Count).End(xlUp).Row + 1).Resize(1, iCol): _
        Range("A" & Target.Row).Resize(1, iCol).Delete shift:=xlUp: _
        sWk.Columns.AutoFit
'
Application.EnableEvents = True
'
End Sub

Il y a peu de lignes avec MFC et listes de validation donc leur poids est négligeable mais sur une feuille de plusieurs milliers de lignes, cela peut engendrer des ralentissements : VBA permet de s'en passer... évidemment, il faut connaître VBA, me diras-tu...

Cela correspond-t-il à tes attentes ? Sinon, explications claires ET complètes...

A+

Plus intelligent ainsi... comme je fais d'habitude, en fait...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
Cells.Validation.Delete
If Not Intersect(Target, Columns(6)) Is Nothing And Range("A" & Target.Row).Value <> "" Then _
    Target.Validation.Add Type:=xlValidateList, Formula1:="=J2:J" & Range("J" & Rows.Count).End(xlUp).Row
'
End Sub

A+

Bonjour à tous

si entre temps GMB solutionne le fichier, 2020

Je m'étais effacé devant mes pairs mais si on a encore besoin de moi...

Nouvelle version :

Bye !

Bonjour,

@GMB, merci! Par contre chaque changement de statut fait apparaître un message qui m'indique que la ligne est passée dans l'onglet sortie mais rien ne se passe (pour être tout à fait honnête je n'ai pas besoin qu'un message s'affiche) par contre j'aime beaucoup la fonction de double click pour faire revenir une ligne! je n'ai pas pu la tester encore vu qu'il doit y avoir une erreur qqpart et que les lignes désignées comme "sortie" ne bougent pas.

@Curulis57, ou est -ce que je remplace ce code? désolé..

@GMB @Curulis57 je ne veux pas vous prendre votre temps chacun de votre côté et me retrouver avec 2 versions de mon fichier (je ne saurai pas lequel choisir) êtes vous tous les deux en train de bosser dessus? et comment on fait, j'envoie une bouteille de vin à chacun après ça?

Ah, on est plutôt dans la dégustation de wisky pour le moment... enfin, si ça va pour toi, hein ?

T'inquiètes pas pour le travail que nous fournissons : c'est pour nous (plus que très souvent) un vrai plaisir !
J'avais oublié le UNDO : j'y retourne!

A+

Non le vin, c'est pour moi

Oups !

Nouvelle version

Bye !

@GMB Merci beaucoup!!

Du coup je constate 3 choses:

1. Lorsque je choisis "Refusé/sortie coffre", la ligne reste là au lieu d'aller dans l'autre onglet.
2. Lorsque je choisis "Terminé/à facturer", la ligne est déplacée alors qu'elle doit rester
3. Lorsque je choisis "Livré/sortie coffre", la ligne reste là au lieu d'aller dans l'autre onglet, et la coloration (mise en forme conditionnelle) se fait sur toutes les cases sauf la dernière (commentaire) qui reste blanche mais la case du dessous se colorie.

Pour rappel, il n'y a que "Refusé/sortie coffre" et "Livré/sortie coffre" qui doivent envoyer la ligne dans l'autre onglet, pour les autres status, la ligne reste. J'ai l'impression de donner des ordres alors qu'on m'aide pour un truc que je n'aurai jamais pu faire seul....

La fonction double click fonctionne c'est hyper pratique!!

Salut djav,
Salut l'équipe,

Fonction UNDO que j'avais oubliée...
- la référence de la ligne déplacée s'inscrit en "mini" à côté de l'en-tête "Statut" ;
- un double-clic sur "Statut" ramène la ligne au bercail et la trie aussitôt ;
- le statut "En cours" est remis à la ligne rapatriée ;
- si tu veux pouvoir choisir quelle ligne ramener au bercail, il faudra une petite liste de validation supplémentaire...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim sWk As Worksheet, iRow%, iRowT%, iCol%
'
Set sWk = Worksheets("Sortie")
'
If Not Intersect(Target, [F1]) Is Nothing And InStr([F1], "/") > 0 Then _
    Application.EnableEvents = False: _
    Cancel = True: _
    iRowT = Range("A" & Rows.Count).End(xlUp).Row + 1: _
    iCol = Cells(1, 1).End(xlToRight).Column: _
    iRow = sWk.Columns(1).Find(what:=CStr(Split([F1], " / ")(1)), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlPrevious).Row: _
    sWk.Range("A" & iRow).Resize(1, iCol).Copy Destination:=Range("A" & iRowT).Resize(1, iCol): _
    sWk.Rows(iRow).Delete shift:=xlUp: _
    [F1] = "Statut": _
    [F1].Interior.Color = xlNone: _
    Application.EnableEvents = True: _
    Range("F" & iRowT).Value = "En cours": _
    Range("A1").Resize(Range("A" & Rows.Count).End(xlUp).Row, iCol).Sort key1:=[A2], order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
'
End Sub

A+

Wow c'est top, vraiment merci beaucoup

@Curulis57 @GMB si je n'envoie pas de vin ou whiskey (je n'y connais rien non plus en whiskey) je fais un don à une assoc.