XL 2019 Copier des lignes non contigue

netparty · 15 Août 2021

Bonjour à tous

Je recherche de l'aide pour réaliser une macro.

Voici ce que cette macro doit faire :

Dans mon classeur j'ai 2 feuilles "Données 1" et "Données 2" et j'aimerai copier toutes les lignes qui contiennent un mot spécifique dans la colonne J (Mot à rechercher : INT58, Sanitaire, Divers-95, 01 Elec, TR.TRAVAUX) ensuite il faut coller les lignes trouvées dans la feuille "Rapport" en-dessous de la dernière ligne non vide.

Dans le fichier exemple les lignes à copier sont entres les lignes surlignée en jaune.

Merci d'avance

Bonne journée à tous

job75 · 15 Août 2021

Bonjour netparty,

netparty à dit:
Dans le fichier exemple les lignes à copier sont surlignée en jaune.

Le problème n'est pas cohérent : les lignes en jaune ont une cellule vide en colonne J.

Joignez un fichier avec le résultat attendu.

A+

netparty · 15 Août 2021

job75 à dit:
Bonjour netparty,

Le problème n'est pas cohérent : les lignes en jaune ont une cellule vide en colonne J.

Joignez un fichier avec le résultat attendu.

A+

Bonjour job75

Je me suis trompé dans mon énoncé, en fait je voudrai copier toutes les lignes qui se trouve entre les lignes jaunes.

Merci

job75 · 15 Août 2021

Voyez le fichier joint et le code de la feuille "Rapport" :

VB:

Private Sub Worksheet_Activate()
Worksheet_Change [A1] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim w As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Cells.Delete 'RAZ
For Each w In Sheets(Array("Données 1", "Données 2"))
    With w.UsedRange
        .AutoFilter 10, "*"
        .Copy Range("A" & Range("J" & Rows.Count).End(xlUp).Row + 1)
        .AutoFilter
    End With
Next
Rows(1).Delete 'supprime la 1ère ligne car elle est vide
Rows(1).Font.Bold = True 'gras
'UsedRange.RemoveDuplicates [COLUMNS(A:AI)], Header:=xlNo 'supprime les lignes en doublon
UsedRange.RemoveDuplicates Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, _
    22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35), Header:=xlNo 'supprime les lignes en doublon
Columns.AutoFit 'ajuste les largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub

La feuille est mise à jour quand on modifie ou valide une cellule quelconque ou quand on l'active.

Bien noter que les lignes en doublon sont supprimées.

Edit : [COLUMNS(A:AI)] ne va pas, j'ai corrigé.

netparty · 16 Août 2021

job75 à dit:

Voyez le fichier joint et le code de la feuille "Rapport" :

VB:

Private Sub Worksheet_Activate()
Worksheet_Change [A1] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim w As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Cells.Delete 'RAZ
For Each w In Sheets(Array("Données 1", "Données 2"))
    With w.UsedRange
        .AutoFilter 10, "*"
        .Copy Range("A" & Range("J" & Rows.Count).End(xlUp).Row + 1)
        .AutoFilter
    End With
Next
Rows(1).Delete 'supprime la 1ère ligne car elle est vide
Rows(1).Font.Bold = True 'gras
UsedRange.RemoveDuplicates [COLUMNS(A:AI)], Header:=xlNo 'supprime les lignes en doublon
Columns.AutoFit 'ajuste les largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub

La feuille est mise à jour quand on modifie ou valide une cellule quelconque ou quand on l'active.

Bien noter que les lignes en doublon sont supprimées.

Bonjour job75

Merci pour ton fichier, j'ai testé il fonctionne très bien mais j'ai quelques remarques.

Les doublon ne doivent pas être supprimés, il faut retranscrire les 2 feuilles dans rapport.
Si j'ai plus que 2 feuille de données y a t-il un moyen facile de les ajouter ?
Et est-il possible de commencer la copie a partir de la ligne 10?

Merci bonne journée

job75 · 16 Août 2021

Bonjour netparty, le forum,

Voyez ce fichier (2) :

VB:

Private Sub Worksheet_Activate()
Worksheet_Change [A1] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ligdeb&, w As Worksheet, P As Range
ligdeb = 9 '1ère ligne à copier
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Cells.Delete 'RAZ
For Each w In Sheets(Array("Données 1", "Données 2", "Feuil4")) 'liste à adapter
    If w.Cells(ligdeb, 10) <> "" Then w.Rows(ligdeb).Copy Rows(1)
    Set P = Intersect(w.Rows(ligdeb & ":" & w.Rows.Count), w.UsedRange)
    If Not P Is Nothing Then
        P.AutoFilter 10, "*"
        With Range("A" & Range("J" & Rows.Count).End(xlUp).Row + 1) '1ère ligne vide
            P.Copy .Cells
            .EntireRow.Delete
        End With
        P.AutoFilter
    End If
Next
Rows(1).Font.Bold = True 'gras
UsedRange.Sort Columns(10), xlAscending, Columns(4), , xlAscending, Columns(12), xlAscending, Header:=True 'tri sur 3 colonnes
Columns.AutoFit 'ajuste les largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub

Je vois qu'il n'y a pas de lignes en doublon et donc que la macro de mon post #4 est incorrecte.

C'est [COLUMNS(A:AI)] qui ne va pas, je vais corriger.

A+

netparty · 16 Août 2021

job75 à dit:

Bonjour netparty, le forum,

Voyez ce fichier (2) :

VB:

Private Sub Worksheet_Activate()
Worksheet_Change [A1] 'lance la macro
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ligdeb&, w As Worksheet, P As Range
ligdeb = 9 '1ère ligne à copier
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Cells.Delete 'RAZ
For Each w In Sheets(Array("Données 1", "Données 2", "Feuil4")) 'liste à adapter
    If w.Cells(ligdeb, 10) <> "" Then w.Rows(ligdeb).Copy Rows(1)
    Set P = Intersect(w.Rows(ligdeb + 1 & ":" & w.Rows.Count), w.UsedRange)
    If Not P Is Nothing Then
        P.AutoFilter 10, "*"
        P.Copy Range("A" & Range("J" & Rows.Count).End(xlUp).Row + 1)
        P.AutoFilter
    End If
Next
Rows(1).Font.Bold = True 'gras
UsedRange.Sort Columns(10), xlAscending, Columns(4), , xlAscending, Columns(12), xlAscending, Header:=True 'tri sur 3 colonnes
Columns.AutoFit 'ajuste les largeurs
Application.EnableEvents = True 'réactive les évènements
End Sub

Je vois qu'il n'y a pas de lignes en doublon et donc que la macro de mon post #4 est incorrecte.

C'est [COLUMNS(A:AI)] qui ne va pas, je vais corriger.

A+

Re job75

Top le fichier

Une dernière demande, est-il possible de ne pas trier les données exportée.

Merci

job75 · 16 Août 2021

netparty à dit:
Une dernière demande, est-il possible de ne pas trier les données exportée.

Vous savez comment faire pour neutraliser une ligne de code non ?

netparty · 16 Août 2021

job75 à dit:
Vous savez comment faire pour neutraliser une ligne de code non ?

Oui j'ai mis la ligne de tri en commentaire, mais maintenant j'ai une ligne vide dans la feuille Rapport

job75 · 16 Août 2021

Oui la macro du post #6 n'allait pas, je viens de corriger.

XL 2019 Copier des lignes non contigue

netparty

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

netparty

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

netparty

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

netparty

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

netparty

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Discussions similaires