XL 2010 Transférer une ligne, sur une autre feuille selon la valeur d'une cellule

[Acritas]

Bonjour,

J'ai deux feuilles sur mon classeur(feuille "Situation" & feuille "Entrepôt")

Selon la valeur d'une des cellules de la colonne C ( "1" ou "0") , je veux que la ligne entière bascule sur la première ligne disponible de la feuille ''Entrepôt"
et vise versa si je change la valeur d'une de ces cellules dans la feuille Entrepôt la ligne revient se coller sur la première ligne disponible de la feuille "Situation"
le tout dois se faire automatiquement sans avoir à faire exécuter le code (appuyer F5) car l'utilisateur lambda ne doit pas toucher à VBA.

Merci par avance pour votre aide

 

[Dranreb]

Bonjour.
Dans le module Feuil1 (Situation) :

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim LSrc As Long, LDst As Long
   If Target.Count > 1 Then Exit Sub
   If Intersect(Me.[C5].Resize(Me.[C1000000].End(xlUp).Row - 4), Target) Is Nothing Then Exit Sub
   If Target.Value <> 0 Then Exit Sub
   Application.EnableEvents = False
   LSrc = Target.Row
   LDst = Feuil2.[B1000000].End(xlUp).Row + 1
   If LDst < 5 Then LDst = 5
   Feuil2.Rows(LDst).Insert
   Me.Rows(LSrc).EntireRow.Cut Feuil2.Rows(LDst)
   Me.Rows(LSrc).Delete xlShiftUp
   Application.EnableEvents = True
   End Sub

Et dans le module Feuil2 (Entrepôt), à peu près le même code, adapté pour le faire dans l'autre sens …

 

[fanch55]

Bonjour,
Qu'entendez-vous par ligne disponible ?
En début de table ou en fin ? trié par ?
Vous avez fait des tables fixes et non structurées, que doit-on faire quand toutes les lignes de vos cadres sont remplies ?

Qu'est-ce qui provoque le transfert : le 1 ou le 0 ? Ne préféreriez-vous pas un transfert par menu contextuel sur une ligne tel que l'exemple ci-contre (ce qui vous permettrait d'en transférer éventuellement un bloc )

 

[job75]

Bonjour à tous,

La macro à placer dans ThisWorkbook :

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim ncol%, Sh1 As Worksheet, Sh2 As Worksheet, ShDest As Worksheet, i&
ncol = 20 'nombre de colonnes
Set Sh1 = Sheets("Situation ") 'pourquoi un espace ???
Set Sh2 = Sheets("Entrepôt")
If Sh.Name = Sh1.Name Then Set ShDest = Sh2
If Sh.Name = Sh2.Name Then Set ShDest = Sh1
If ShDest Is Nothing Then Exit Sub
If Sh.Cells(Target.Row, 3) <> 1 Then Exit Sub
i = 5
While ShDest.Cells(i, 2) <> "": i = i + 1: Wend
With Sh.Cells(Target.Row, 2).Resize(, ncol)
    ShDest.Cells(i, 2).Resize(, ncol).FormulaR1C1 = .FormulaR1C1
    .ClearContents 'RAZ*
End With
Application.Goto ShDest.Cells(i, 2) 'facultatif
End Sub

Double-clic sur la ligne à transférer.

A+

 

[Acritas]

s

Bonjour,

Merci beaucoup pour votre retour,

S'il vous plait comme je suis un bleu de chez bleu sur VBA est-il possible de me mettre des commentaires explicatifs sur les différentes ligne de votre code ?

Merci bien !

 

[Acritas]

Bonjour,
Qu'entendez-vous par ligne disponible ?
En début de table ou en fin ? trié par ?
Vous avez fait des tables fixes et non structurées, que doit-on faire quand toutes les lignes de vos cadres sont remplies ?

Qu'est-ce qui provoque le transfert : le 1 ou le 0 ? Ne préféreriez-vous pas un transfert par menu contextuel sur une ligne tel que l'exemple ci-contre (ce qui vous permettrait d'en transférer éventuellement un bloc )

Regarde la pièce jointe 1164911

Qu'entendez-vous par ligne disponible ? --> le tableau doit conserver les lignes qui y ont été placées précédemment --> donc les nouvelles saisies doivent arriver en dessous de la dernière ligne qui y était(sauf si elle a été renvoyée dans l'autre feuille ( d'où le "première ligne disponible")

Vous avez fait des tables fixes et non structurées, que doit-on faire quand toutes les lignes de vos cadres sont remplies ?
--> le transfert continue à s'appliquer en conservant la mise en forme
Qu'est-ce qui provoque le transfert : le 1 ou le 0 ?
--> le "0"

Ne préféreriez-vous pas un transfert par menu contextuel sur une ligne tel que l'exemple ci-contre
(ce qui vous permettrait d'en transférer éventuellement un bloc )
--> ce serait parfait dans le menu contextuel

Voilà, j'espère avoir été plus claire

 

[Phil69970]

Bonjour @Acritas et bienvenu sur XLD

Je te propose cette version

Merci de ton retour

@Phil69970

 

[Acritas]

i = 5

qu'est-ce que cela signifie svp?

Okay, c'est bon, j'ai vu

 

[Acritas]

Bonjour @Acritas et bienvenu sur XLD

Je te propose cette version

Merci de ton retour

Bonjour

si je comprend bien après je refait le même code pour les mouvements de la seconde feuille, ?

autre question :
si j'ai 50 formules dans le fichier définitif... dois-je reproduire le code suivant Pour chaque formule?

--> " WsDst.Range("H" & DerligDst).FormulaLocal = "=Somme(E" & DerligDst & ":G" & DerligDst & ")" ' Trim1 Formule du T1"

En d'autre termes que faut-il faire pour que la ligne soit récupérée avec les formules et les mises en forme de la feuille initiale ? --> les formules doivent êtres exactement les mêmes, la feuille "Entrepôt" n'est pas prévue pour effectuer des calculs juste du stockage temporaire de données : je fermerais la saisie de données de toutes les cellule à l'exception des cellules de la colonne "C"

- Précision : les 50 formules et les 100 mises en formes peuvent être totalement différentes

 

[Phil69970]

Bonjour à tous

@Acritas

si je comprend bien après je refait le même code pour les mouvements de la seconde feuille, ?

Si tu as bien regardé c'est déjà fait mon fichier le fait dans les 2 sens

autre question :
si j'ai 50 formules dans le fichier définitif... dois-je reproduire le code suivant Pour chaque formule?

Oui bien sur.

D’où l’intérêt de mettre à disposition un fichier représentatif

C'est quoi représentatif ?

- représentatif, même organisation des lignes et des colonnes, mêmes libellés, mêmes noms de feuilles...
- anonymisé, pas de données personnelles réelles tels nom, n° sécu, adresse ...
- simplifié, une quinzaine de lignes reproduisant l'ensemble des différents cas envisageables (Avec le résultat souhaité)
*Éventuellement préciser l'ordre de grandeur des lignes à traiter, exemple mon fichier comporte 1 000 lignes ou bien 200 000 lignes ==> la méthodologie peut être différents.
Une demande claire donne très souvent une réponse rapide et qui correspond au mieux à la demande.
Donc si cela fonctionne sur le fichier fourni et pas sur le vrai fichier j'en conclu qu'il n'est en rien représentatif ou que tu n'as pas su transposer ce qui devrait être un simple copier coller.

*Je pars toute cette après midi et je ne rentre que tard le soir donc je ne pourrais pas répondre à tes questions avant ce soir

@Phil69970

 

[Dranreb]

des commentaires explicatifs sur les différentes ligne de votre code

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim LSrc As Long, LDst As Long
   If Target.Count > 1 Then Exit Sub ' Si la plage changée comporte plusieurs cellules on sort.
   If Intersect(Me.[C5].Resize(Me.[C1000000].End(xlUp).Row - 4), Target) Is Nothing Then Exit Sub
      ' Si la cellule changée n'est pas comprise dans la plage commençant à C5 pour un nombre de ligne égal
      ' au numéro de ligne de la dernière cellule renseignée diminué de 4, on sort.
   If Target.Value <> 0 Then Exit Sub ' si la cellule changée ne vaut pas 0 on sort.
   Application.EnableEvents = False ' Désactive les évènements pour ne pas provoquer d'appel récursif de Sub Worksheet_Change
   LSrc = Target.Row ' Ligne de la cellule changée
   LDst = Feuil2.[B1000000].End(xlUp).Row + 1 ' Ligne destinatrice après celle de la dernière renseignée
   If LDst < 5 Then LDst = 5 ' au moins 5 si tout est vide
   Feuil2.Rows(LDst).Insert ' Insersion ligne
   Me.Rows(LSrc).EntireRow.Cut Feuil2.Rows(LDst) ' Couper/Coller le contenu
   Me.Rows(LSrc).Delete xlShiftUp ' Supprimer la ligne source
   Application.EnableEvents = True ' Rétablit les évènements
   End Sub

 

[Acritas]

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim LSrc As Long, LDst As Long
   If Target.Count > 1 Then Exit Sub ' Si la plage changée comporte plusieurs cellules on sort.
   If Intersect(Me.[C5].Resize(Me.[C1000000].End(xlUp).Row - 4), Target) Is Nothing Then Exit Sub
      ' Si la cellule changée n'est pas comprise dans la plage commençant à C5 pour un nombre de ligne égal
      ' au numéro de ligne de la dernière cellule renseignée diminué de 4, on sort.
   If Target.Value <> 0 Then Exit Sub ' si la cellule changée ne vaut pas 0 on sort.
   Application.EnableEvents = False ' Désactive les évènements pour ne pas provoquer d'appel récursif de Sub Worksheet_Change
   LSrc = Target.Row ' Ligne de la cellule changée
   LDst = Feuil2.[B1000000].End(xlUp).Row + 1 ' Ligne destinatrice après celle de la dernière renseignée
   If LDst < 5 Then LDst = 5 ' au moins 5 si tout est vide
   Feuil2.Rows(LDst).Insert ' Insersion ligne
   Me.Rows(LSrc).EntireRow.Cut Feuil2.Rows(LDst) ' Couper/Coller le contenu
   Me.Rows(LSrc).Delete xlShiftUp ' Supprimer la ligne source
   Application.EnableEvents = True ' Rétablit les évènements
   End Sub

Merci bien, je vous reviens

 

[fanch55]

Dans le classeur ci-joint,
les tables ont été converties en tables structurées de nom "situation" et "entrepot" .
Le menu contextuel accessible par clic droit sur une des lignes des tables vous permettra de faire les transferts.
Les formules sont respectées.

 

[job75]

Fichier (2) si l'on ne veut pas laisser une ligne vide intermédiaire :

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim ncol%, Sh1 As Worksheet, Sh2 As Worksheet, ShDest As Worksheet, i&, memo
ncol = 20 'nombre de colonnes
Set Sh1 = Sheets("Situation ") 'pourquoi un espace ???
Set Sh2 = Sheets("Entrepôt")
If Sh.Name = Sh1.Name Then Set ShDest = Sh2
If Sh.Name = Sh2.Name Then Set ShDest = Sh1
If ShDest Is Nothing Then Exit Sub
If Sh.Cells(Target.Row, 3) <> 1 Then Exit Sub
i = 5
While ShDest.Cells(i, 2) <> "": i = i + 1: Wend
With Sh.Cells(Target.Row, 2).Resize(, ncol)
    ShDest.Cells(i, 2).Resize(, ncol).FormulaR1C1 = .FormulaR1C1
    .ClearContents 'RAZ*
    memo = .Offset(1).CurrentRegion.Resize(, ncol).FormulaR1C1 'mémorise
    .Resize(UBound(memo)).FormulaR1C1 = memo 'décale vers le haut
    .Offset(UBound(memo)).ClearContents 'efface la dernière ligne
End With
Application.Goto ShDest.Cells(i, 2) 'facultatif
End Sub

 

[job75]

Qu'est-ce qui provoque le transfert : le 1 ou le 0 ?
--> le "0"

Moi j'ai considéré que c'était le 1 puisqu'il y a des 1 dans la 1ère feuille !