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

Acritas

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

Pièces jointes

  • Fichier de Test.xlsx
    18.4 KB · Affichages: 13

Dranreb

XLDnaute Barbatruc
Bonjour.
Dans le module Feuil1 (Situation) :
VB:
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

XLDnaute Barbatruc
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 )
1678008768224.png
 

job75

XLDnaute Barbatruc
Bonjour à tous,

La macro à placer dans ThisWorkbook :
VB:
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+
 

Pièces jointes

  • Fichier de Test(1).xlsm
    26.7 KB · Affichages: 7

Acritas

XLDnaute Nouveau
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
 
Dernière édition:

Acritas

XLDnaute Nouveau
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
 
Dernière édition:

Phil69970

XLDnaute Barbatruc
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

XLDnaute Barbatruc
des commentaires explicatifs sur les différentes ligne de votre code
VB:
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

XLDnaute Nouveau
VB:
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

XLDnaute Barbatruc
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.Acritas.gif
 

Pièces jointes

  • Fichier de Test.xlsm
    38.8 KB · Affichages: 9
Dernière édition:

job75

XLDnaute Barbatruc
Fichier (2) si l'on ne veut pas laisser une ligne vide intermédiaire :
VB:
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
 

Pièces jointes

  • Fichier de Test(2).xlsm
    27.3 KB · Affichages: 6

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof