VBA - Copier certains éléments d'une ligne d'une feuille à une autre et les suppr. de 1ere feuille

donpopo · 5 Avril 2018

Bonjour le forum,
Je suis confronté à un problème ou plutôt plusieurs.
Je désire, en cliquant sur une cellule précise d'une ligne d'une feuilleX (colonne A) copier certaines données de cette ligne sélectionnée vers une feuilleY.

1er problème: lorsque je veux utiliser la procédure que je suis en train d'élaborer, un message d'erreur apparaît car j'ai déjà une procédure qui porte le même nom (faisant le même type d'opération).
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

2eme problème: je cherche à trouver la première ligne vide dans la feuille de destination (feuilleY)

3eme problème mineur: je ne sais si la ligne de commande que j'ai placée dans la procédure efface bien le contenu seul de toutes les cellules de la feuilleX en laissant les bordures et les formules.

Pour essayer d'être plus clair, j'ai joint mon fichier de travail. Les procédures dont question se trouvent sur la Feuille "Compte_Titres1" (feuille d'où les données seront extraites); la fauille de destination est "ARCHIVES".

J'espère avoir été assez clair. Des détails se trouvent en commentaire dans la procédure concernée.
Si quelqu'un pouvait m'aider?

bonne journée,
donpopo

youky(BJ) · 5 Avril 2018

Bonjour donpopo,
essaye ceci ca doit passer, il existe aussi le double_click ou right_click
Je trouve le selectionchange trop rapide.....
Bruno

VB:

' Cette procédure ouvre un userform lorsque l'on clique sur une des cellules de la colonne B à condition qu'il y ait une valeur sur la ligne.
' Ce userform affiche des données de la ligne concernée.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long, j As Long, xlgn As Long, xdlgn As Long, xcol As Long, xmttl As Double, DerCol As Long, nrlign As Long
If Application.Intersect(Target, Range("b5:b" & xdlgn)) Is Nothing Then
      xdlgn = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row
            xlgn = Target.Row
            xcol = ActiveSheet.Cells(xlgn, Columns.Count).End(xlToLeft).Column
            If ActiveSheet.Cells(xlgn, 6) < "01/01/1900" Then
                  MsgBox "Aucun Compte-titres ne figure sur cette ligne.", vbInformation, "COMPTES-TITRES"
                  Exit Sub
            End If
            UserForm2.TextBox1.Value = Cells(xlgn, 3).Value
            UserForm2.TextBox2.Value = Cells(xlgn, 8).Value
            UserForm2.TextBox3.Value = Cells(xlgn, 6).Value
            UserForm2.TextBox4.Value = Cells(xlgn, 9).Value
            UserForm2.TextBox4.Value = Format(UserForm2.TextBox4.Value, "### ##0.00")
            UserForm2.TextBox5.Value = Cells(xlgn, xcol).Value
            UserForm2.TextBox5.Value = Format(UserForm2.TextBox5.Value, "### ##0.00")
            UserForm2.TextBox6.Value = UserForm2.TextBox5.Value - UserForm2.TextBox4.Value
            UserForm2.TextBox6.Value = Format(UserForm2.TextBox6.Value, "### ##0.00")
            If UserForm2.TextBox6.Value < 0 Then
                UserForm2.TextBox6.ForeColor = vbRed
            End If
            UserForm2.TextBox7.Value = Cells(xlgn, 5).Value
            UserForm2.TextBox8.Value = Cells(xlgn, 4).Value
            UserForm2.TextBox8.Value = Format(UserForm2.TextBox8.Value, "### ##0.00")
            UserForm2.TextBox9.Value = UserForm2.TextBox5.Value - UserForm2.TextBox4.Value + UserForm2.TextBox8.Value
            UserForm2.TextBox9.Value = Format(UserForm2.TextBox9.Value, "### ##0.00")
            If UserForm2.TextBox9.Value < 0 Then
                UserForm2.TextBox9.ForeColor = vbRed
            End If
            UserForm2.TextBox10.Value = Cells(2, 4).Value
            Range("A3").Activate
            UserForm2.Show
End If

If Application.Intersect(Target, Range("A5:A" & xdlgn)) Is Nothing Then
    xdlgn = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row
    xlgn = Target.Row
    xcol = ActiveSheet.Cells(xlgn, Columns.Count).End(xlToLeft).Column
     If ActiveSheet.Cells(xlgn, 6) < "01/01/1900" Then
            MsgBox "Aucun Compte-titres ne figure sur cette ligne.", vbInformation, "COMPTES-TITRES"
            Exit Sub
     End If
            'COPIER CERTAINES DONNEES DANS ARCHIVES
    nrlign = sheets("ARCHIVES").Range("C" & Rows.Count).End(xlUp).Row + 1
    Worksheets("CPTE_TITRES1").Cells(xlgn, 3).Value.Copy Worksheet("ARCHIVES").Cells(nrlign, 2).Value
' VIDER LE CONTENU DE LA LIGNE CONCERNEE DANS CPTE_TITRES1 EN GARDANT LES FORMULES
        Rows(xlgn).SpecialCells(xlCellTypeConstants, 23).ClearContents
End If
End Sub

Nairolf · 5 Avril 2018

Salut,

En complément de la réponse de Bruno, voici quelques éléments de réponse à tes questions:

1) Il faut que tu regroupes tes procédures en une seule => le changement de sélection de cellule dans cette feuille activera les deux codes concernés par cet événement commun.

2) Il y a plusieurs façon de le faire, par exemple:

VB:

Range("B1048576").End(xlUp).Row + 1

3) ClearContents a bien l'effet d'effacer le contenu des cellules considérées.

youky(BJ) · 5 Avril 2018

re, il y a boulette dans mon code précédent
Voici rectifé

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long, j As Long, xlgn As Long, xdlgn As Long, xcol As Long, xmttl As Double, DerCol As Long, nrlign As Long
xdlgn = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row
If Not Application.Intersect(Target, Range("b5:b" & xdlgn)) Is Nothing Then
    
            xlgn = Target.Row
            xcol = ActiveSheet.Cells(xlgn, Columns.Count).End(xlToLeft).Column
            If ActiveSheet.Cells(xlgn, 6) < "01/01/1900" Then
                  MsgBox "Aucun Compte-titres ne figure sur cette ligne.", vbInformation, "COMPTES-TITRES"
                  Exit Sub
            End If
            UserForm2.TextBox1.Value = Cells(xlgn, 3).Value
            UserForm2.TextBox2.Value = Cells(xlgn, 8).Value
            UserForm2.TextBox3.Value = Cells(xlgn, 6).Value
            UserForm2.TextBox4.Value = Cells(xlgn, 9).Value
            UserForm2.TextBox4.Value = Format(UserForm2.TextBox4.Value, "### ##0.00")
            UserForm2.TextBox5.Value = Cells(xlgn, xcol).Value
            UserForm2.TextBox5.Value = Format(UserForm2.TextBox5.Value, "### ##0.00")
            UserForm2.TextBox6.Value = UserForm2.TextBox5.Value - UserForm2.TextBox4.Value
            UserForm2.TextBox6.Value = Format(UserForm2.TextBox6.Value, "### ##0.00")
            If UserForm2.TextBox6.Value < 0 Then
                UserForm2.TextBox6.ForeColor = vbRed
            End If
            UserForm2.TextBox7.Value = Cells(xlgn, 5).Value
            UserForm2.TextBox8.Value = Cells(xlgn, 4).Value
            UserForm2.TextBox8.Value = Format(UserForm2.TextBox8.Value, "### ##0.00")
            UserForm2.TextBox9.Value = UserForm2.TextBox5.Value - UserForm2.TextBox4.Value + UserForm2.TextBox8.Value
            UserForm2.TextBox9.Value = Format(UserForm2.TextBox9.Value, "### ##0.00")
            If UserForm2.TextBox9.Value < 0 Then
                UserForm2.TextBox9.ForeColor = vbRed
            End If
            UserForm2.TextBox10.Value = Cells(2, 4).Value
            Range("A3").Activate
            UserForm2.Show
End If
xdlgn = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row
If Not Application.Intersect(Target, Range("A5:A" & xdlgn)) Is Nothing Then
    xlgn = Target.Row
    xcol = ActiveSheet.Cells(xlgn, Columns.Count).End(xlToLeft).Column
     If ActiveSheet.Cells(xlgn, 6) < "01/01/1900" Then
            MsgBox "Aucun Compte-titres ne figure sur cette ligne.", vbInformation, "COMPTES-TITRES"
            Exit Sub
     End If
            'COPIER CERTAINES DONNEES DANS ARCHIVES
    nrlign = sheets("ARCHIVES").Range("C" & Rows.Count).End(xlUp).Row + 1
    Worksheets("CPTE_TITRES1").Cells(xlgn, 3).Value.Copy Worksheets("ARCHIVES").Cells(nrlign, 2).Value
' VIDER LE CONTENU DE LA LIGNE CONCERNEE DANS CPTE_TITRES1 EN GARDANT LES FORMULES
        Rows(xlgn).SpecialCells(xlCellTypeConstants, 23).ClearContents
End If
End Sub

donpopo · 5 Avril 2018

Bonsoir Youky(BJ) et Nairolf,
Merci pour vos conseils. Je vais tester la proposition de Youky(BJ).
Cependant, il est vrai que j'avais pensé relier les deux procédures en une seule. Seulement, je ne vois pas très bien comment procéder. Il faudrait sûrement ouvrir un userform me proposant soit d'archiver, soit d'afficher mon userform de présentation de la valeur.
Je vais prendre la solution de Youky(BJ), mais vais me pencher sur une solution pour les réunir.
Encore merci,

youky(BJ) · 5 Avril 2018

Désolé encore des boulettes j'avais pas tout testé
Bruno

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long, j As Long, xlgn As Long, xdlgn As Long, xcol As Long, xmttl As Double, DerCol As Long, nrlign As Long
If Target.Row < 4 Then Exit Sub
If Target.Column = 2 Then
xdlgn = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row
            xlgn = Target.Row
            xcol = ActiveSheet.Cells(xlgn, Columns.Count).End(xlToLeft).Column
            If ActiveSheet.Cells(xlgn, 6) < "01/01/1900" Then
                  MsgBox "Aucun Compte-titres ne figure sur cette ligne.", vbInformation, "COMPTES-TITRES"
                  Exit Sub
            End If
            UserForm2.TextBox1.Value = Cells(xlgn, 3).Value
            UserForm2.TextBox2.Value = Cells(xlgn, 8).Value
            UserForm2.TextBox3.Value = Cells(xlgn, 6).Value
            UserForm2.TextBox4.Value = Cells(xlgn, 9).Value
            UserForm2.TextBox4.Value = Format(UserForm2.TextBox4.Value, "### ##0.00")
            UserForm2.TextBox5.Value = Cells(xlgn, xcol).Value
            UserForm2.TextBox5.Value = Format(UserForm2.TextBox5.Value, "### ##0.00")
            UserForm2.TextBox6.Value = UserForm2.TextBox5.Value - UserForm2.TextBox4.Value
            UserForm2.TextBox6.Value = Format(UserForm2.TextBox6.Value, "### ##0.00")
            If UserForm2.TextBox6.Value < 0 Then
                UserForm2.TextBox6.ForeColor = vbRed
            End If
            UserForm2.TextBox7.Value = Cells(xlgn, 5).Value
            UserForm2.TextBox8.Value = Cells(xlgn, 4).Value
            UserForm2.TextBox8.Value = Format(UserForm2.TextBox8.Value, "### ##0.00")
            UserForm2.TextBox9.Value = UserForm2.TextBox5.Value - UserForm2.TextBox4.Value + UserForm2.TextBox8.Value
            UserForm2.TextBox9.Value = Format(UserForm2.TextBox9.Value, "### ##0.00")
            If UserForm2.TextBox9.Value < 0 Then
                UserForm2.TextBox9.ForeColor = vbRed
            End If
            UserForm2.TextBox10.Value = Cells(2, 4).Value
            Range("A3").Activate
            UserForm2.Show
            Exit Sub
End If
If Target.Column = 1 Then
If MsgBox("Vous voulez Archiver !", vbExclamation + vbYesNo, "CONFIRMATION") = vbNo Then Exit Sub
    xdlgn = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row
    xlgn = Target.Row
    xcol = ActiveSheet.Cells(xlgn, Columns.Count).End(xlToLeft).Column
     If ActiveSheet.Cells(xlgn, 6) < "01/01/1900" Then
            MsgBox "Aucun Compte-titres ne figure sur cette ligne.", vbInformation, "COMPTES-TITRES"
            Exit Sub
     End If
            'COPIER CERTAINES DONNEES DANS ARCHIVES
    nrlign = sheets("ARCHIVES").Range("B" & Rows.Count).End(xlUp).Row + 1
    sheets("ARCHIVES").Cells(nrlign, 2).Value = Cells(xlgn, 3).Value
' VIDER LE CONTENU DE LA LIGNE CONCERNEE DANS CPTE_TITRES1 EN GARDANT LES FORMULES
        Rows(xlgn).SpecialCells(xlCellTypeConstants, 23).ClearContents
End If
End Sub

donpopo · 5 Avril 2018

Une question youky(BJ),
comment fais tu pour colorer ainsi tes codes VBA?

youky(BJ) · 5 Avril 2018

hello donpopo,
J'utilise la 4ème icône ci-dessus en partant de la droite (insérer)
Choisir VB et copie ton code, le résultat se fait tout seul
Chez toi je crois qu'il existe une option qui colorie les mots clés ne je ne sais plus ou c'est.
Chez moi le code n'est pas colorier
Tu peux améliorer encore le code voici
Bruno

VB:

If MsgBox("Vous voulez Archiver !" & vbCr & Cells(target.row, 3), vbExclamation + vbYesNo, "CONFIRMATION") = vbNo Then Exit Sub

donpopo · 6 Avril 2018

Bonjour le forum,
Je reviens sur la procédure (exacte) proposée par youky(BJ).
Rows(xlgn).SpecialCells(xlCellTypeConstants, 23).ClearContents

Lorsque je désire supprimer tous les éléments d'une ligne en fin de procédure sauf les bordures et les formules, j'ai oublié de mentionner que je ne désirais pas toucher aux colonnes 1 et 1, colonnes qui doivent rester pleines.
Quel est le moyen pour arriver à ce résultat?
D'avance merci,
donpopo

youky(BJ) · 6 Avril 2018

re:
Voici à partir de colonne C à AA à modifier si besoin
Range ("C" & xlgn & ":AA" & xlgn).SpecialCells(xlCellTypeConstants, 23).ClearContents
Bruno

donpopo · 6 Avril 2018

Merci, merci!
Je ne savais pas comment libeller ce range()
Georges

VBA - Copier certains éléments d'une ligne d'une feuille à une autre et les suppr. de 1ere feuille

donpopo

XLDnaute Occasionnel

Pièces jointes

youky(BJ)

XLDnaute Barbatruc

Nairolf

XLDnaute Accro

youky(BJ)

XLDnaute Barbatruc

donpopo

XLDnaute Occasionnel

youky(BJ)

XLDnaute Barbatruc

donpopo

XLDnaute Occasionnel

youky(BJ)

XLDnaute Barbatruc

donpopo

XLDnaute Occasionnel

youky(BJ)

XLDnaute Barbatruc

donpopo

XLDnaute Occasionnel

Discussions similaires