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

Acritas · 5 Mars 2023

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

fanch55 · 8 Mars 2023

Acritas à dit:
Besoin d'une variante de code qui n'agit pas sur la mise en forme originale des cellules

Qu'entendez-vous par mise en forme ?

Format de présentation du contenu
Couleur des cellules
Largeur des cellules

Acritas · 8 Mars 2023

fanch55 à dit:
Qu'entendez-vous par mise en forme ?

Format de présentation du contenu

Couleur des cellules

Largeur des cellules

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

fanch55 · 8 Mars 2023

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

Pour avoir une identité visuelle, j'avais différencié les couleurs des 2 tables.
Classeur corrigé .

job75 · 8 Mars 2023

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+

Acritas · 8 Mars 2023

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+

@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 ?

job75 · 8 Mars 2023

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.

Acritas · 8 Mars 2023

job75 à dit:
Q5 : la macro fonctionne avec les 2 boutons, ce sont les définitions de Sh et ShDest qui distinguent les feuilles.

Comment les monte-t-on?

Acritas · 8 Mars 2023

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 …

@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 !

job75 · 8 Mars 2023

Acritas à dit:
Comment les monte-t-on?

Il n'y a rien à "monter" (???) la macro se débrouille toute seule.

Pourquoi cette ligne de code en jaune ? La feuille de destination ShDest est protégée ?

Acritas · 8 Mars 2023

job75 à dit:
Il n'y a rien à "monter" (???) la macro se débrouille toute seule.

Pourquoi cette ligne de code en jaune ? La feuille de destination ShDest est protégée ?

oui elle l'est...

job75 · 8 Mars 2023

Acritas à dit:
oui elle l'est...

Alors vous avez oublié de mettre le code pour la déprotéger...

Acritas · 8 Mars 2023

S'il vous plait, quelqu'un, peut-il m'aider à permettre à la macro suivante de s'exécuter indépendamment d'un mot de passe? protégeant chacune des feuilles concernées?

job75 à dit:
Alors vous avez oublié de mettre le code pour la déprotéger...

'ignore comment le faire ... je suis en début d'apprentissage

Acritas · 8 Mars 2023

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

job75 · 8 Mars 2023

Non ce n'est pas correct.

Avec le couper-coller UserInterfaceOnly:=True ne va pas.

Il faut Unprotect comme indiqué dans mon post #36.

Acritas · 8 Mars 2023

P

job75 à dit:
Non ce n'est pas correct.

Avec le couper-coller UserInterfaceOnly:=True ne va pas.

Il faut Unprotect comme indiqué dans mon post #36.

Peut-être qu'il faut me débloquer parce que vraiment là...

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

Acritas

XLDnaute Nouveau

Pièces jointes

fanch55

XLDnaute Barbatruc

Acritas

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Acritas

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Acritas

XLDnaute Nouveau

Acritas

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Acritas

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Acritas

XLDnaute Nouveau

Pièces jointes

Acritas

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Acritas

XLDnaute Nouveau

Discussions similaires