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

G
  • Résolu(e)
Copie de données d'une feuille à une autre
Réponses
2
Affichages
194
gui22
G
G
  • Résolu(e)
Microsoft 365 Copie d'une ligne vers une autre feuille VBA
Réponses
4
Affichages
476
Dranreb
Dranreb
P
  • Question
XL 2019 Copier des cellules d'une feuille sur une autre
Réponses
2
Affichages
221
phoceenjo
P
_l_ours
  • Résolu(e)
XL 2016 Créer une feuille si elle n'existe pas + Copier une plage de cellule d'une feuille à l'autre
Réponses
9
Affichages
215
_l_ours
_l_ours
N
  • Résolu(e)
Microsoft 365 Copie de données d'une feuille à une autre
Réponses
4
Affichages
166
Cousinhub
Cousinhub
chris6999
  • Question
Microsoft 365 MACRO VBA - Extraire des listes à partir d'une boucle
Réponses
5
Affichages
195
chris6999
chris6999
M
  • Question
XL 2021 Copier coller les valeur d'une ligne si la case contiens "x"
Réponses
2
Affichages
391
manga419
M
D
  • Question
XL 2016 macro pour copier coller des cellules d'une feuille dans une autre feuille avec condition
Réponses
2
Affichages
247
Phil69970
Phil69970
P
  • Question
XL 2019 Modification d'une ligne d'une autre feuille lors d'un echange d'effet dans un userform
Réponses
11
Affichages
465
TooFatBoy
TooFatBoy
N
  • Question
XL 2010 Mise à jour automatique d'une feuille via une autre feuille d'un même classeur
Réponses
0
Affichages
379
NoOne38
N

Membres actuellement en ligne

23 membres et 283 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 158
Messages
2 085 830
Membres
102 994
dernier inscrit
snoopy70