XL 2019 Macro pour copier ligne avec case à cocher liée

nobru_26 · 23 Février 2025

Bonjour à tous,

Voilà 1 jour que j'écume le WEB à la recherche d'un code à modifier pour copier une ligne Excel dans une autre feuille si la case à cocher (liée à chaque cellule) est VRAI, copie des valeurs des cellules de la ligne dans la feuille 2.

Je vais faire un fichier démo mais pour explications:

Feuille 1 colonne A4 à A500 il y a des cases à cocher liées aux cellules respectives A4 à A500.
Si je coche les cellules je veux que cela copie la ligne correspondante dans la feuille 2 à partir de A4 par exemple et si la cellule est libre (il faut donc détecter la première ligne vide de feuille 2). Il n'est pas nécessaire de copier la colonne A de feuille 1 puisque ce n'est qu'une sélection.

Macro à lancer, pas de détection Change, et je veux copier la ligne sur 10 colonnes (les valeurs car j'ai des indirects sur la feuille 1).

J'ai essayé des codes, mais le "VRAI" semble poser problème, j'ai testé avec des chiffres, cela semble fonctionner mais je n'arrive pas à recaler le second tableau et le VRAI ne veux pas fonctionner....

Je suis dans le flou et je n'arrive plus à maitriser les boucles FOR et autres fonctions, le backout quoi.... c'est peut-être parce que je me tape une grippe aussi!

Merci pour votre aide par avance!

Valtrase · 26 Février 2025

Bonjour,
Avez-vous vérifié que le code correspond à ceux des postes posts #6 et #7 ?
Le définitif devrait ressembler à celà.

VB:

Option Explicit
Option Compare Text

Sub RunCopy_Cliquer()
    CopyData Factory.InitTabData, Factory.InitTabSelectedData
End Sub

Sub RunClearAndCopy_Cliquer()
    CopyData Factory.InitTabData, Factory.InitTabSelectedData, True
End Sub

'@Description "Copie les lignes sélectionnées."
Public Sub CopyData(ByVal TableSource As Excel.ListObject, ByVal TableCible As Excel.ListObject, Optional ByVal ClearTab As Boolean)
    Dim Restaure As Boolean
    Restaure = Application.ScreenUpdating
    Application.ScreenUpdating = False

    If Not TableSource Is Nothing And Not TableCible Is Nothing Then
        Dim itemRow...

nobru_26 · 23 Février 2025

Voilà pour le fichier DE BASE sans mes essais car c'est de pire en pire.... Je n'arrive plus à rien!

nobru_26 · 23 Février 2025

nobru_26 à dit:
Voilà pour le fichier DE BASE sans mes essais car c'est de pire en pire.... Je n'arrive plus à rien!

Bon j'avance un peu mais je n'arrive pas à modifier cetet fonction pour prendre la valeur de la cellule, car comme je suis en INDIRECT sur le fichier cela ne fonctionne pas et me recopie les formules, si je mets de valeurs dans la plage cela fonctionne.

Il faut donc copier et coller Valeur.

Sub Worksheet_Change()

Dim sh, i, DernCol As Integer
Dim Wb_dest As String
Dim Wb_dep As String

Application.ScreenUpdating = False

Wb_dep = ActiveWorkbook.Name
'Récupération de la position de la cellule active
lgn = ActiveCell.Row
Col = ActiveCell.Column

'effacements des données de la feuille "DPX"
Sheets("DPX").Select
Sheets("DPX").Range("A4").Select
Sheets("DPX").Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
Sheets("DPX").Range("A4").Select

Ligne = 4
For i = 2 To Workbooks(Wb_dep).Sheets(1).Range("A510").End(xlUp).Row
If Workbooks(Wb_dep).Sheets(1).Range("A" & i) = True Then

Workbooks(Wb_dep).Sheets(1).Range("B" & i & ":Q" & i).Copy Workbooks(Wb_dep).Sheets("DPX").Range("A" & Ligne)
Ligne = Ligne + 1
End If
Next i

' Repositionnement sur la cellule
Sheets("LISTE_DA").Select
Sheets("LISTE_DA").Cells(lgn, Col).Select

End Sub

Merci

Valtrase · 23 Février 2025

Bonjour Nobru,
If faut travailler avec des tableaux structurés, autant pour la source que pour la cible.
Je les ai nommés vt_Data et vt_SelectedData mais cela peut être changé dans le module Factory dans lequel ils sont initialisés.
J'ai aussi ajouter des case à cocher dans le tableau Data (Je ne sais pas si c'est disponible sous 2019).
Ceci fait il ne reste qu'a boucler sur la première colonne vérifier si c'est coché si oui on copie.
Par défaut les lignes s'ajoute au tableau cible (vt_SelectedData).

Code:

'@Description "Copie les lignes sélectionnées."
Public Sub CopyData(ByVal TableSource As Excel.ListObject, ByVal TableCible As Excel.ListObject, Optional ByVal ClearTab As Boolean)
    If Not TableSource Is Nothing And Not TableCible Is Nothing Then
        Dim itemRow As Excel.ListRow
        If ClearTab Then
            If Not TableCible.DataBodyRange Is Nothing Then TableCible.DataBodyRange.Delete
        End If
        For Each itemRow In TableSource.ListRows
            With itemRow
                If .Range(.Parent.ListColumns("Sélectionnez").Index).Value = True Then
                    Dim NewRow As Excel.ListRow
                    Set NewRow = TableCible.ListRows.Add
                    itemRow.Range.Cells(1, 2).Resize(1, 15).Copy Destination:=NewRow.Range.Cells(1, 1)
                End If
            End With
        Next
    Else
        MsgBox "Oupss... Nous avons rencontré une erreur ! Tableaux non trouvés dans le classeur."
    End If
End Sub

Ces macros initialisent les tableaux et lance la copie, avec ou sans effacement du tableau cible.

Code:

Sub RunCopy_Cliquer()
    CopyData Factory.InitTabData, Factory.InitTabSelectedData
End Sub

Sub RunClearAndCopy_Cliquer()
    CopyData Factory.InitTabData, Factory.InitTabSelectedData, True
End Sub

Voilà bonne programmation.

nobru_26 · 24 Février 2025

Hello et un grand merci pour ton fichier, cela m'approche de la solution.

Cependant 2 questions, pourquoi la macro effacer et copier les données semble ne copier que la dernière ligne ayant le VRAI, elle ne copie pas les autres lignes VRAI.

Et aussi comme la macro plus haut que j'ai testé, comme ma base est en adressage indirect (formules dans les cellules) ta macro copie la cellule et donc se retrouve avec une formule qui n'a rien à voir avec celle de départ, il faudrait coller "valeur" est-ce possible?

Merci

Valtrase · 24 Février 2025

Bonsoir,

Cependant 2 questions, pourquoi la macro effacer et copier les données semble ne copier que la dernière ligne ayant le VRAI, elle ne copie pas les autres lignes VRAI.

Peut-être n'ai-je pas mis à jour le fichier regardez au niveau de cette procédure :

VB:

'@Description "Copie les lignes sélectionnées."
Public Sub CopyData(ByVal TableSource As Excel.ListObject, ByVal TableCible As Excel.ListObject, Optional ByVal ClearTab As Boolean)
    If Not TableSource Is Nothing And Not TableCible Is Nothing Then
        Dim itemRow As Excel.ListRow
        If ClearTab Then
            If Not TableCible.DataBodyRange Is Nothing Then TableCible.DataBodyRange.Delete
        End If
        For Each itemRow In TableSource.ListRows
            With itemRow
                If .Range(.Parent.ListColumns("Sélectionnez").Index).Value = True Then
                    Dim NewRow As Excel.ListRow
                    Set NewRow = TableCible.ListRows.Add
                    itemRow.Range.Cells(1, 2).Resize(1, 15).Copy Destination:=NewRow.Range.Cells(1, 1)
                End If
            End With
        Next
    Else
        MsgBox "Oupss... Nous avons rencontré une erreur ! Tableaux non trouvés dans le classeur."
    End If
End Sub

Et aussi comme la macro plus haut que j'ai testé, comme ma base est en adressage indirect (formules dans les cellules) ta macro copie la cellule et donc se retrouve avec une formule qui n'a rien à voir avec celle de départ, il faudrait coller "valeur" est-ce possible?

Là j'avoue ne pas comprendre. Ci dessous je coche les trois premières :

Et le résultat sur la feuille DPX :

Point de formule ici...

Valtrase · 24 Février 2025

Re,
J'étais intrigué donc j'ai revérifié. Sur mon fichier je n'ai plus les relations avec d'autres classeurs, ni de formules.
Faites un test en changeant le type de collage en spécial.

VB:

                If .Range(.Parent.ListColumns("Sélectionnez").Index).Value = True Then
                    Dim NewRow As Excel.ListRow
                    Set NewRow = TableCible.ListRows.Add
                    itemRow.Range.Cells(1, 2).Resize(1, 15).Copy
                    NewRow.Range.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats ' // A adapter selon le cas voir : https://learn.microsoft.com/fr-fr/office/vba/api/excel.xlpastetype
                End If

nobru_26 · 24 Février 2025

Bonsoir,

Je vais re-regarder, je suis HS ce soir...

Mais déjà je n'ai pas les cases à cocher, sans doute la version, mais c'est pas grave je les mettrai par la suite.

Lorsque je fait effacer et copier les données je n'ai qu'une ligne de résultat dans DPX la dernière ligne VRAI du tableau.

Lorsque je fais copier les données, j'ai la fameuse dernière ligne au départ puis les autres lignes VRAI à la suite, mais la dernière ligne est donc doublée.

Je suis paumé et trop juste en connaissances VBA sur les datatables mais je vais regarder demain
Un grand merci pour ce temps passé!

Pour l'histoire des formules, effectivement j'ai eliminé les liens pour le forum, car il faut un autre fichier qui est un export de données, données liées à ce fichier dans le feuille ListeDA, ce n'est que des formules qui pointent sur le fichier exterieur.

Valtrase · 26 Février 2025

Bonjour,
Avez-vous vérifié que le code correspond à ceux des postes posts #6 et #7 ?
Le définitif devrait ressembler à celà.

VB:

Option Explicit
Option Compare Text

Sub RunCopy_Cliquer()
    CopyData Factory.InitTabData, Factory.InitTabSelectedData
End Sub

Sub RunClearAndCopy_Cliquer()
    CopyData Factory.InitTabData, Factory.InitTabSelectedData, True
End Sub

'@Description "Copie les lignes sélectionnées."
Public Sub CopyData(ByVal TableSource As Excel.ListObject, ByVal TableCible As Excel.ListObject, Optional ByVal ClearTab As Boolean)
    Dim Restaure As Boolean
    Restaure = Application.ScreenUpdating
    Application.ScreenUpdating = False

    If Not TableSource Is Nothing And Not TableCible Is Nothing Then
        Dim itemRow As Excel.ListRow
        If ClearTab Then
            If Not TableCible.DataBodyRange Is Nothing Then TableCible.DataBodyRange.Delete
        End If
        For Each itemRow In TableSource.ListRows
            With itemRow
                If .Range(.Parent.ListColumns("Sélectionnez").Index).Value = True Then
                    Dim NewRow As Excel.ListRow
                    Set NewRow = TableCible.ListRows.Add
                    itemRow.Range.Cells(1, 2).Resize(1, 15).Copy
                    NewRow.Range.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats ' // A adapter selon les besoins : https://learn.microsoft.com/fr-fr/office/vba/api/excel.xlpastetype
                    Application.CutCopyMode = False
                End If
            End With
        Next
        
    Else
        MsgBox "Oupss... Nous avons rencontré une erreur ! Tableaux non trouvés dans le classeur."
    End If
    Application.ScreenUpdating = Restaure
End Sub

Lors de l’appui sur le bouton de gauche, la copie se fait sans vérification des lignes existantes. Si vous voulez ne recopier que les lignes supplémentaires il faut adapter le code.

Phil69970 · 26 Février 2025

Bonjour à tous

@nobru_26

Après quelques jours de vacances .....
Je te propose ce fichier, tout est paramétrable .... et sans case à cocher (la taille du fichier est divisé par 10 ) 😉
Exemple de paramétrage :
==> Suppression des données de la feuille de destination avant copie
==> Suppression des doublons après copie
==> Ne rien supprimer et copier toutes les lignes à la suite
==> Décocher toutes les croix après copie (dernière ligne du code à activer dans le code VBA)
==> Message de fin avec le nombre de lignes copiées et le nombre de doublon supprimées

La 1ere fois la feuille de destination est crée si elle n'existe pas
J'ai commenté tout le code et j'ai mis quelques variantes possible que tu peux modifier dans le code
Bien sur des adaptations sont possible .....

Merci de ton retour

Phil69970 · 27 Février 2025

Bonjour à tous

@nobru_26

Phil69970 à dit:
Merci de ton retour

Aucun retour de ta part c'est pas trop cool de ta part et c'est pas faute de l'avoir écrit !!!

nobru_26 · 28 Février 2025

Bonjour,

Encore mes excuses mais comme évoqué dans le premier post, je suis en cours de convalescence d'une bonne bonne grippe, j'ai pas vu le soleil depuis quelques jours et j'ai encore du mal à me concentrer et vos réponses à tous les deux sont OK avec ma demande mais il me faut un peu de temps pour comprendre vos lignes de codes.

Valtrase, j'ai remis le code que tu as posté après et je n'ai plus le soucis de double ligne, il devait y a voir un bug et cela fonctionne parfaitement.

Phil69970, ce fichier fonctionne aussi parfaitement! Je vais regarder comment pouvoir garder la feuille DPX qui aura des zones d'entête fixes afin que la création du tableau ne vienne pas décaler ou écraser, repositionner le tableau etc...

Je vais maintenant essayer de trouver l'Energie de décoder et peaufiner les solutions pour l'adapter à mon besoin final, encore un grand merci et désolé pour mon absence momentanée!
Je reviendrai surement pour des éclaircissements sur les lignes de code.
Merci!

Phil69970 · 28 Février 2025

@nobru_26

Comme je l'ai dit :

Phil69970 à dit:
Bien sur des adaptations sont possible .....

L’intérêt est de voir le paramétrage de mon fichier qui est très facile à comprendre.

Phil69970 à dit:
J'ai commenté tout le code et j'ai mis quelques variantes possible que tu peux modifier dans le code

XL 2019 Macro pour copier ligne avec case à cocher liée

nobru_26

XLDnaute Nouveau

Valtrase

nobru_26

XLDnaute Nouveau

Pièces jointes

nobru_26

XLDnaute Nouveau

Valtrase

XLDnaute Occasionnel

Pièces jointes

nobru_26

XLDnaute Nouveau

Valtrase

XLDnaute Occasionnel

Valtrase

XLDnaute Occasionnel

nobru_26

XLDnaute Nouveau

Valtrase

XLDnaute Occasionnel

Phil69970

XLDnaute Barbatruc

Pièces jointes

Phil69970

XLDnaute Barbatruc

nobru_26

XLDnaute Nouveau

Phil69970

XLDnaute Barbatruc

Discussions similaires

XL 2019 Macro pour copier ligne avec case à cocher liée

XLDnaute Nouveau

XLDnaute Nouveau

Pièces jointes

XLDnaute Nouveau

XLDnaute Occasionnel

Pièces jointes

XLDnaute Nouveau

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Nouveau

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Nouveau

​

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency