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

A

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
Trier par date Trier par votes
A

Acritas

XLDnaute Nouveau
fanch55 à dit:
Qu'entendez-vous par mise en forme ?
  • Format de présentation du contenu
  • Couleur des cellules
  • Largeur des cellules
Cliquez pour agrandir...

  • Format de présentation du contenu
  • Couleur des cellules
  • Largeur des cellules
  • les formules de calculs(également)--> les cellules sont copiés tel qu'elle... j'ai au préalable, fait la mise en forme dans l'onglet de destination ainsi que positionné exactement au même endroit les cellules qui servent à effectuer les calculs
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
Acritas à dit:
  • Format de présentation du contenu
  • Couleur des cellules
  • Largeur des cellules
  • les formules de calculs(également)--> les cellules sont copiés tel qu'elle... j'ai au préalable, fait la mise en forme dans l'onglet de destination ainsi que positionné exactement au même endroit les cellules qui servent à effectuer les calculs
Cliquez pour agrandir...
Pour avoir une identité visuelle, j'avais différencié les couleurs des 2 tables.
Classeur corrigé .
 

Pièces jointes

  • Fichier de Test F55.xlsm
    39.8 KB · Affichages: 3
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour Acritas, le fil,

La solution de mon fichier (4) ne semble pas avoir de succès.

Peut-être parce qu'elle paraît trop compliquée.

Dans ce fichier (5) en voici une autre, plus simple, qui utilise un tri de regroupement et le couper-coller :
VB: 
Sub Transfert()
Dim ncol%, Sh As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet, ShDest As Worksheet, critere As Byte, n&, i&, j&, rc&
ncol = 20 'nombre de colonnes
Set Sh = ActiveSheet
Set Sh1 = Sheets("Situation ") 'pourquoi un espace ???
Set Sh2 = Sheets("Entrepôt")
If Sh.Name = Sh1.Name Then Set ShDest = Sh2: critere = 0
If Sh.Name = Sh2.Name Then Set ShDest = Sh1: critere = 1
If ShDest Is Nothing Then Exit Sub
If Sh.FilterMode Then Sh.ShowAllData 'si la feuille est filtrée
If ShDest.FilterMode Then ShDest.ShowAllData 'si la feuille est filtrée
With Sh.Range("B5:B" & Sh.Range("E" & Sh.Rows.Count).End(xlUp).Row).Resize(, ncol)
    If .Row < 5 Then Exit Sub 'si le tableau est vide
    n = Application.CountIf(.Columns(2), critere)
    If n = 0 Then Exit Sub
    Application.ScreenUpdating = False
    .Sort .Columns(2), IIf(critere = 0, xlDescending, xlAscending), Header:=xlNo 'tri pour regrouper et accélérer
    .Borders.LineStyle = xlNone 'efface toute bordure
    i = Application.Match(critere, .Columns(2), 0)
    j = ShDest.Range("E" & ShDest.Rows.Count).End(xlUp).Row + 1
    rc = .Rows.Count 'mémorise
    .Rows(i).Resize(n).Cut ShDest.Cells(j, 2) 'couper-coller
    If n < rc Then
        .BorderAround Weight:=xlMedium 'pourtour
        .Borders(xlEdgeTop).LineStyle = xlNone
    End If
End With
With ShDest.Cells(j, 2).Resize(n, ncol)
    .BorderAround Weight:=xlMedium 'pourtour
    .Borders(xlEdgeTop).LineStyle = xlNone
End With
ShDest.Activate 'facultatif
End Sub
Pour tester j'ai recopié le tableau de la 1ère feuille sur 51 000 lignes, durées d'exécution chez moi :

- fichier (4) => 5,9 secondes

- fichier (5) => 7,6 secondes, c'est un peu moins rapide.

A+
 

Pièces jointes

  • Fichier de Test(5).xlsm
    32.3 KB · Affichages: 5
Vote positif 0 Vote négatif
A

Acritas

XLDnaute Nouveau
job75 à dit:
Bonjour Acritas, le fil,

La solution de mon fichier (4) ne semble pas avoir de succès.

Peut-être parce qu'elle paraît trop compliquée.

Dans ce fichier (5) en voici une autre, plus simple, qui utilise un tri de regroupement et le couper-coller :
VB: 
Sub Transfert()
Dim ncol%, Sh As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet, ShDest As Worksheet, critere As Byte, n&, i&, j&, rc&
ncol = 20 'nombre de colonnes
Set Sh = ActiveSheet
Set Sh1 = Sheets("Situation ") 'pourquoi un espace ???
Set Sh2 = Sheets("Entrepôt")
If Sh.Name = Sh1.Name Then Set ShDest = Sh2: critere = 0
If Sh.Name = Sh2.Name Then Set ShDest = Sh1: critere = 1
If ShDest Is Nothing Then Exit Sub
If Sh.FilterMode Then Sh.ShowAllData 'si la feuille est filtrée
If ShDest.FilterMode Then ShDest.ShowAllData 'si la feuille est filtrée
With Sh.Range("B5:B" & Sh.Range("E" & Sh.Rows.Count).End(xlUp).Row).Resize(, ncol)
    If .Row < 5 Then Exit Sub 'si le tableau est vide
    n = Application.CountIf(.Columns(2), critere)
    If n = 0 Then Exit Sub
    Application.ScreenUpdating = False
    .Sort .Columns(2), IIf(critere = 0, xlDescending, xlAscending), Header:=xlNo 'tri pour regrouper et accélérer
    .Borders.LineStyle = xlNone 'efface toute bordure
    i = Application.Match(critere, .Columns(2), 0)
    j = ShDest.Range("E" & ShDest.Rows.Count).End(xlUp).Row + 1
    rc = .Rows.Count 'mémorise
    .Rows(i).Resize(n).Cut ShDest.Cells(j, 2) 'couper-coller
    If n < rc Then
        .BorderAround Weight:=xlMedium 'pourtour
        .Borders(xlEdgeTop).LineStyle = xlNone
    End If
End With
With ShDest.Cells(j, 2).Resize(n, ncol)
    .BorderAround Weight:=xlMedium 'pourtour
    .Borders(xlEdgeTop).LineStyle = xlNone
End With
ShDest.Activate 'facultatif
End Sub
Pour tester j'ai recopié le tableau de la 1ère feuille sur 51 000 lignes, durées d'exécution chez moi :

- fichier (4) => 5,9 secondes

- fichier (5) => 7,6 secondes, c'est un peu moins rapide.

A+
Cliquez pour agrandir...
@job75,

Je suis entrain de regarder les différentes solution en essayant d'apprendre par la même occasion.

Question 1 : est-il possible d'avoir plus de détails possibles sur les différentes lignes de code ?

Question 2 : Se pose désormais une problématique de verrouillages en écriture des différents onglets, quel serait la variante de ton code ?

Question 3 : je vois que ton code prend en compte le ''pourtour'' qu'en serait-il si tu retirais cette contrainte?

Question 4 : quel est le sens de cette ligne de code : If .Row < 5 Then Exit Sub je la vois dans différents codes

Question 5 : Quelle est la ligne de code en rapport avec votre bouton de transfert des données ?
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Q1 : non, car il faudrait expliquer chaque mot, faites des recherches sur le web.

Q2 : si les feuilles sont protégées il faut les déprotéger en début de macro avec les codes :
VB: 
Sh.Unprotect "toto" 'mot de passe
ShDest.Unprotect "toto"
et les protéger en fin de macro.

Q3 : c'est pour appliquer des bordures sur le pourtour de la plage, on peut ne pas en mettre.

Q4 : si le tableau est vide .Row = 4 donc ce code arrête la macro.

Q5 : la macro fonctionne avec les 2 boutons, ce sont les définitions de Sh et ShDest qui distinguent les feuilles.
 
Vote positif 0 Vote négatif
A

Acritas

XLDnaute Nouveau
job75 à dit:
Q5 : la macro fonctionne avec les 2 boutons, ce sont les définitions de Sh et ShDest qui distinguent les feuilles.
Cliquez pour agrandir...
Comment les monte-t-on?

1678292741883.png
 
Vote positif 0 Vote négatif
A

Acritas

XLDnaute Nouveau
Dranreb à dit:
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 …
Cliquez pour agrandir...
@Dranreb

Te serait-il possible de permettre dans ton code la prise en compte d'un mot de passe verrouillant les cellules au départ et à l'arrivée ?

merci bien !
 
Vote positif 0 Vote négatif
A

Acritas

XLDnaute Nouveau
j'ai trouvé le code suivant :

/
VB: 
Private Sub Workbook_Open()
  Dim sh As Worksheet
  For Each sh In Sheets
    sh.Protect Password:="MDP", userinterfaceonly:=True
  Next sh
End Sub
et

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Dim sh As Worksheet
  For Each sh In Sheets
    sh.UnProtect Password:="MDP", userinterfaceonly:=False
  Next sh
End Sub

--> Dans le module ThisWorkbook . Cella vous semble-t-il correcte être adapté et opportun ?

Merci bien
 
Vote positif 0 Vote négatif

Discussions similaires

A
  • Question
XL 2019 Ajouter ou supprimer une ligne selon un mot trouvé dans une autre feuille
Réponses
1
Affichages
145
Oneida
Oneida
D
  • Question
Microsoft 365 combiner deux plages de données sur deux feuilles excel différentes pour un TCD
Réponses
4
Affichages
218
Daniel200666
D
C
  • Question
XL 2021 Transfert d'une feuille sur une autre feuille
Réponses
2
Affichages
283
clausen
C
J
  • Question
Autres Supprimer une ligne dans une feuille à partir d'une valeur rentrée dasn une cellule d'une autre feuille
2
Réponses
25
Affichages
1 K
jmc78
J
13Hubert
  • Résolu(e)
Microsoft 365 VBA - Coller la valeur d'une cellule d'une autre feuille...
Réponses
11
Affichages
504
13Hubert
13Hubert
M
  • Question
XL 2019 VBA Valeur d'une cellule dont la feuille et la ligne est dans la feuille courante
Réponses
13
Affichages
402
job75
job75
RyuAutodidacte
  • Résolu(e)
Microsoft 365 Obtenir par formule/champs nommés … ? la valeur d'une cellule de la feuille active que récupère une feuille non active … possible ? (sans vba)
2
Réponses
18
Affichages
663
RyuAutodidacte
RyuAutodidacte
Z
  • Question
XL 2021 VBA Prélèvement d'une donnée si une valeur recherchée est identique
Réponses
3
Affichages
185
ZiM
Z
A
  • Résolu(e)
XL 2016 Remplissage couleur sur deux cellules renvoie une valeur dans une autre cellule
Réponses
4
Affichages
413
Al1_44
A
M
  • Question
XL 2016 Recopier une formule une cellule sur deux sans saut de ligne dans les données sources
Réponses
5
Affichages
512
Maria25
M

Membres actuellement en ligne

2 membres et 33 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 177
Messages
2 085 972
Membres
103 073
dernier inscrit
MSCHOE16