Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

Créer une discussion
  • Initiateur de la discussion Initiateur de la discussion donpopo
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire

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

Trier par date Trier par votes
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
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
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
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
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
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
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
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

M
  • Résolu(e)
XL 2021 Copier/Coller des valeurs d’une feuille à une autre à partir d’une cellule
Réponses
11
Affichages
453
MANU64360
M
  • Résolu(e)
XL 2019 Problème de copie de plages non contiguës vers une autre feuille en VBA
Réponses
9
Affichages
289
flc13090
F
  • Question Question
Autres Récupération de données d'une feuille X en fonction de la valeur de cellule dans une collone d'une feuille Y
2
Réponses
27
Affichages
1 K
fanfan38
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
534
Webperegrino
W
A
  • Résolu(e)
Microsoft 365 programme VBA pour "importer" les valeurs de certaines cellules d'une autre feuille appartenant à une ligne que j'identifie par un n°
2
Réponses
27
Affichages
1 K
arnomorize
A
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
778
steph_29120
S
P
  • Question Question
XL 2021 Ajout/adaptation de code VBA sur feuille qui en contient déjà
Réponses
3
Affichages
341
Pierreavecunp
P
P
  • Question Question
XL 2019 Macro VBA appliquer un filtre lors d'une importation de données
Réponses
1
Affichages
389
fanch55
N
  • Question 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
842
Nel'
N
S
  • Question Question
Microsoft 365 VBA pour copier une une des données d'une ligne à une autre
Réponses
3
Affichages
938
salma_hayek
S
A
  • Résolu(e)
XL 2016 Transfert de formule d'une feuille à une autre.
Réponses
2
Affichages
525
Al1_44
A
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
1 K
S.J
S
A
  • Question Question
XL 2019 Ajouter ou supprimer une ligne selon un mot trouvé dans une autre feuille
Réponses
1
Affichages
478
Oneida
M
  • Question 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
818
MGH
M
G
  • Résolu(e)
Microsoft 365 Copie d'une ligne vers une autre feuille VBA
Réponses
4
Affichages
818
Dranreb
G
  • Résolu(e)
Copie de données d'une feuille à une autre
Réponses
2
Affichages
652
gui22
G
C
  • Résolu(e)
Autres Code VBA pour recherche et copie/coller de ligne avec mot clé.
Réponses
12
Affichages
836
Corentin26270
C
A
  • Question Question
XL 2021 Générer des données à partir d'une ligne spécifique jusqu'à une autre
Réponses
5
Affichages
545
gbinforme
G
P
  • Question Question
XL 2021 Code VBA pour copier coller des données de cellules d'une feuille a une autre
2
Réponses
15
Affichages
1 K
lafleur
L
G
  • Question Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
771
GClaire
G
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…