Copie de lignes en fonction d'une colonne particulière

Le 21/04/2023 à 15:49

Bonjour à tous,

9lastupdate-pour-forum.xlsx (13.10 Ko)

Ma macro VBA ne fonctionne pas comme je le souhaite, j'ai besoin de vos lumières.

J'aimerai que la macro ordonne une copie de la ligne entière d'une feuille nommée "J-1" en feuille nommée "Histo" uniquement si dans les cellules de la colonne C de la feuille "J-1" n'existe pas dans la les cellules de la colonne C de la feuille nommée "J".

Il est important que les lignes copiés en "Histo" soient copiés après la dernière ligne utilisé de cette feuille "Histo". La macro ne le fait pas ! voila le problème : elle copie les lignes en remplaçant les lignes déjà existante en Histo.

Vous trouverez un fichier type attaché.

Je vous joins le code :

Sub CopierLigneVersHisto()
    Dim j As Integer, lastrowJ1 As Integer, lastrowHisto As Integer
    Dim match As Range, wsJ1 As Worksheet, wsJ As Worksheet, wsHisto As Worksheet

    Set wsJ1 = ThisWorkbook.Sheets("J-1")
    Set wsJ = ThisWorkbook.Sheets("J")
    Set wsHisto = ThisWorkbook.Sheets("Histo")

    lastrowJ1 = wsJ1.cells(wsJ1.Rows.Count, "C").End(xlUp).Row
    lastrowHisto = wsHisto.cells(wsHisto.Rows.Count, "A").End(xlUp).Row

    For j = 2 To lastrowJ1
        Set match = wsJ.cells.Find(What:=wsJ1.cells(j, "C").Value, LookIn:=xlValues, LookAt:=xlWhole)
        If match Is Nothing Then
            lastrowHisto = lastrowHisto + 1
            wsJ1.Rows(j).Copy Destination:=wsHisto.Range("A" & lastrowHisto)
        End If
    Next j
End Sub

Merci à vous !

Le 21/04/2023 à 16:36

Je ne comprends bien où se situe le pb. Pour moi votre macro fonctionne normalement. Les lignes de la feuille J-1 dont les clés sont 6548954654, 23189465 et 13549517 sont bien ajoutées à l'historique.

Le 24/04/2023 à 09:19

Bonjour Optimix,

Merci pour ta réponse. Le problème est que les lignes copiés en Histo se copient juste après l'en-tête et supprime les lignes existantes.

Il est important qu'elles se copient à la suite des lignes déjà existante en Histo pour justement garder l'historique. Je ne trouve pas de solu pour arranger celà.

Le 24/04/2023 à 10:22

Hello,

Normal, tu as défini lastrowHisto hors de ta boucle donc quand tu fais ta copie, lastrowhisto n'est pas incrémenté. Du ocup ta variable est un nombre fixe et à chaque fois tu repars de ce nombre fixe +1 donc tu colles toujours sur la même ligne. Il fallait juste déplacer la ligne dans la boucle pour que ta variable s'adapte

Essaie ça :

Sub CopierLigneVersHisto()
    Dim j As Integer, lastrowJ1 As Integer, lastrowHisto As Integer
    Dim match As Range, wsJ1 As Worksheet, wsJ As Worksheet, wsHisto As Worksheet

    Set wsJ1 = ThisWorkbook.Sheets("J-1")
    Set wsJ = ThisWorkbook.Sheets("J")
    Set wsHisto = ThisWorkbook.Sheets("Histo")

    lastrowJ1 = wsJ1.cells(wsJ1.Rows.Count, "C").End(xlUp).Row

    For j = 2 To lastrowJ1
        Set match = wsJ.cells.Find(What:=wsJ1.cells(j, "C").Value, LookIn:=xlValues, LookAt:=xlWhole)
        If match Is Nothing Then
            lastrowHisto = wsHisto.cells(wsHisto.Rows.Count, "A").End(xlUp).Row
            lastrowHisto = lastrowHisto + 1
            wsJ1.Rows(j).Copy Destination:=wsHisto.Range("A" & lastrowHisto)
        End If
    Next j
End Sub

@+

Le 24/04/2023 à 10:46

bonjour Baroute,

Nop ca ne fonctionne toujours pas sur mon fichier alors que j'ai remplacer avec ta version de la macro.

Le 24/04/2023 à 11:05

Hello,

Fait le test mais moi j'ai bien des lignes qui se rajoutent dans histo...

@+

6lastupdate-pour-forum.xlsm (20.30 Ko)
Le 24/04/2023 à 12:01

Voici une copie de ce que donne votre code. Qu'est-ce qui ne va pas ?

screenshot
Le 24/04/2023 à 12:32

Je suis d'accord que ce code fonctionne maintenant que j'ai fais la modification indiqué par Baroute sur le fichier transmis sur mon premier post.

Mais le hic est que sur mon fichier original contenant des centaines de lignes dans les 3 feuilles chaque une. Lorsque j'actionne la macro (modifié) cela ne change pas mon pb, les lignes sont copiés juste en dessous de l'en-tête, en effaçant les lignes déjà présentent. Encore moins compréhensible car cette partie de la macro est activé en premier lieu, puis d'autres ordres sont données à la suite de la macro.

Pour que ce soit plus clairs voici ma macro entière... ce n'est que pour info et pour votre curiosité :

Sub TROIS()

    Dim j As Integer, lastrowJ1 As Integer, lastrowHisto As Integer
    Dim match As Range, wsJ1 As Worksheet, wsJ As Worksheet, wsHisto As Worksheet

    Set wsJ1 = ThisWorkbook.Sheets("J-1")
    Set wsJ = ThisWorkbook.Sheets("J")
    Set wsHisto = ThisWorkbook.Sheets("Histo")

    lastrowJ1 = wsJ1.cells(wsJ1.Rows.Count, "C").End(xlUp).Row

    For j = 2 To lastrowJ1
        Set match = wsJ.cells.Find(What:=wsJ1.cells(j, "C").Value, LookIn:=xlValues, LookAt:=xlWhole)
        If match Is Nothing Then
            lastrowHisto = wsHisto.cells(wsHisto.Rows.Count, "A").End(xlUp).Row
            lastrowHisto = lastrowHisto + 1
            wsJ1.Rows(j).Copy Destination:=wsHisto.Range("A" & lastrowHisto)
        End If
    Next j

        'Insert en rechercheV le N°grp
        Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("J") 'set the worksheet to "J"

    'determine the last row of the table
    Dim lastRow As Long
    lastRow = ws.cells(ws.Rows.Count, "B").End(xlUp).Row

    'insert VLOOKUP formula in the last row of the table
    ws.Range("D2:D" & lastRow).Formula = "=VLOOKUP(D2,'J-1'!D:AW,2,FALSE)"

    Sheets("j").Range("D:D").Copy
    Sheets("J").Range("D:D").PasteSpecial xlPasteValues
    Application.CutCopyMode = False

    'Effacer les "0" et #N/A
    Sheets("J").Select
    cells.Select
    Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

        'Effacer et recrée feuille J-1
    Dim FJ1 As Worksheet
    Dim wstram As Worksheet

    ' Vérifier si la feuille "J-1" existe déjà, la supprimer si c'est le cas
    On Error Resume Next
    Set FJ1 = ThisWorkbook.Worksheets("J-1")
    On Error GoTo 0
    If Not FJ1 Is Nothing Then
        Application.DisplayAlerts = False
        FJ1.Delete
        Application.DisplayAlerts = True
    End If

    ' Créer une nouvelle feuille "J-1" et la placer en avant-dernier position
    Set FJ1 = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    FJ1.Name = "J-1"
    FJ1.Move After:=ThisWorkbook.Worksheets(1)

    Set wstram = ThisWorkbook.Worksheets("TRAM")

    'Copie des en-têtes
    wstram.Rows(1).Copy Destination:=FJ1.Rows(1)

    'Masquer les colonnes "N°6" et "N°10"
    Columns("I").EntireColumn.Hidden = True
    Columns("M").EntireColumn.Hidden = True

    ' Formater les colonnes en comptabilité pour la feuille J
    Sheets("J").Range("AL:AR").NumberFormat = "#,##0.00 €;[Red]-#,##0.00 €"

    Sheets("J").Range("AT:AW").NumberFormat = "#,##0.00 €;[Red]-#,##0.00 €"

    ' Formater la colonne en date pour la feuille J
    Sheets("J").Range("AF:AG").NumberFormat = "dd/mm/yyyy"

    ' Formater les colonnes en comptabilité pour la feuille J-1
    Sheets("J-1").Range("AL:AR").NumberFormat = "#,##0.00 €;[Red]-#,##0.00 €"

    Sheets("J-1").Range("AT:AW").NumberFormat = "#,##0.00 €;[Red]-#,##0.00 €"

    ' Formater la colonne en date pour la feuille J-1
    Sheets("J-1").Range("AF:AG").NumberFormat = "dd/mm/yyyy"

    ' Formater les colonnes en pourcentage
    Sheets("J").Range("AS:AS, AX:AX, BA:BA").NumberFormat = "0.00%"
    Sheets("J-1").Range("AS:AS, AX:AX, BA:BA").NumberFormat = "0.00%"

    Dim lastR As Long
    lastR = Sheets("J").cells(Rows.Count, "Z").End(xlUp).Row 'détermine la dernière ligne de la colonne Z

    'boucle à travers chaque cellule de la colonne Z, à partir de la deuxième ligne
    For j = 2 To lastR
        Sheets("J").Range("Z" & j).ClearFormats 'effacer la mise en forme
    Next j

    'boucle à travers chaque cellule de la colonne X, à partir de la deuxième ligne
    For i = 2 To lastR
        If Sheets("J").Range("Z" & i).Value = "Expedié" Then 'si la cellule contient "expédié"
            Sheets("J").Range("Z" & i).Interior.Color = vbGreen 'mettre en vert
        ElseIf Sheets("J").Range("Z" & i).Value = "Mail envoyé" Then 'si la cellule contient "mail envoyé"
            Sheets("J").Range("Z" & i).Interior.Color = vbYellow 'mettre en jaune
        ElseIf Sheets("J").Range("Z" & i).Value = "Attente" Or Sheets("J").Range("Z" & i).Value = "Prête" Then 'si la cellule contient "Attente" ou "Prête"
            Sheets("J").Range("Z" & i).Interior.Color = RGB(255, 165, 0) 'mettre en orange
        End If
    Next i

    Dim last As Long
    last = Sheets("J").cells(Rows.Count, "X").End(xlUp).Row 'détermine la dernière ligne de la colonne X

    'boucle à travers chaque cellule de la colonne X, à partir de la deuxième ligne
    For j = 2 To last
        Sheets("J").Range("X" & j).ClearFormats 'effacer la mise en forme
    Next j

    'boucle à travers chaque cellule de la colonne W, à partir de la deuxième ligne
    For k = 2 To last
        Sheets("J").Range("W" & k).ClearFormats 'effacer la mise en forme
    Next k

    'boucle à travers chaque cellule de la colonne S, à partir de la deuxième ligne
    For l = 2 To last
        Sheets("J").Range("S" & l).ClearFormats 'effacer la mise en forme
    Next l

    'boucle à travers chaque cellule de la colonne X, à partir de la deuxième ligne
    For i = 2 To last
        If Sheets("J").Range("X" & i).Value > 0 Then 'si la cellule contient une valeur supérieure à 0
            Sheets("J").Range("X" & i).Interior.Color = vbGreen 'mettre en vert
        End If
    Next i

    'boucle à travers chaque cellule de la colonne W, à partir de la deuxième ligne
    For m = 2 To last
        If Sheets("J").Range("W" & m).Value > 0 Then 'si la cellule contient une valeur supérieure à 0
            Sheets("J").Range("W" & m).Interior.Color = vbRed 'mettre en rouge
        End If
    Next m

    'boucle à travers chaque cellule de la colonne S, à partir de la deuxième ligne
    For n = 2 To last
        If Sheets("J").Range("S" & n).Value > 0 Then 'si la cellule contient une valeur supérieure à 0
            Sheets("J").Range("S" & n).Interior.Color = RGB(255, 199, 206) 'mettre en RVB (255;199;206)
            Sheets("J").Range("S" & n).Font.Color = RGB(156, 0, 6) 'mettre les lettres en RVB (156;0;6)
        End If
    Next n

    Sheets("J").Select

End Sub
Le 24/04/2023 à 12:44

Hello,

Envoie ton fichier de base avec le problème.

Sinon, exécute pas à pas la macro pour voir à quel niveau ça coince.

@+

Le 24/04/2023 à 13:48

Je ne peux pas envoyé le fichier, il comporte des données confidentiel. J'avais fais un fichier similaire pour pouvoir le partagé ici justement.

En exécutant pas à pas il n'affiche aucun problème. Il ne tient tout simplement pas en compte la commande pour aller à la fin du dossier

Le 24/04/2023 à 13:56

Difficile de vous suivre si vous avez modifié le contenu de votre 1er fil. Bon courage pour la suite.

Le 24/04/2023 à 14:01

Hello,

Je suis du même avis que Optimix…

Pas possible de l’anonymiser ?

Rechercher des sujets similaires à "copie lignes fonction colonne particuliere"