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

donpopo

donpopo

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

Pièces jointes

  • COMPTES-TITRES - travail.xlsm
    4.8 MB · Affichages: 34
Trier par date Trier par votes
youky(BJ)

youky(BJ)

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
N

Nairolf

XLDnaute Accro
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.
 
Vote positif 0 Vote négatif
youky(BJ)

youky(BJ)

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
donpopo

donpopo

XLDnaute Occasionnel
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,
 
Vote positif 0 Vote négatif
youky(BJ)

youky(BJ)

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
youky(BJ)

youky(BJ)

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
donpopo

donpopo

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif

Discussions similaires

W
  • Résolu(e)
XL 2016 Gestion de liste transposée dans une autre feuille avec décalage d'une colonne et exclusion de certains éléments
Réponses
9
Affichages
416
Webperegrino
W
S
  • Résolu(e)
XL 2016 copier des données d'une feuille à une autre selon critères et protection de la feuille 1
Réponses
6
Affichages
421
steph_29120
S
B
  • Question
XL 2016 Compiler les données de différente feuille
2
Réponses
15
Affichages
685
Bebzinda
B
S
  • Question
Microsoft 365 VBA pour copier une une des données d'une ligne à une autre
Réponses
3
Affichages
608
salma_hayek
S
N
  • Question
Microsoft 365 afficher/masquer des lignes en fonction de la valeur d'une cellule qui aura été renseignée par une autre feuille (via un copier/collé automatique)
Réponses
5
Affichages
444
Nel'
N
M
  • Question
XL 2019 Transposer des données d'une feuille vers une autre sous forme de synthèse
Réponses
8
Affichages
262
mromain
mromain
A
  • Résolu(e)
XL 2016 Transfert de formule d'une feuille à une autre.
Réponses
2
Affichages
414
Al1_44
A
M
  • Question
XL 2019 Copier des lignes les unes a la suite des autres dans une autre feuille sous conditions et seulement certaines colonnes
Réponses
7
Affichages
636
MGH
M
chris6999
  • Question
Microsoft 365 Copier une plage vers une autre feuille depuis un USF
Réponses
4
Affichages
192
chris6999
chris6999
S
  • Résolu(e)
Microsoft 365 Copier automatiquement sur une ligne sur une autre feuille si la date est supérieur à une date définie
2
Réponses
17
Affichages
985
S.J
S

Membres actuellement en ligne

15 membres et 247 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
315 106
Messages
2 116 271
Membres
112 706
dernier inscrit
Pierre_98