XL 2016 Copie de nouvelles valeurs sur 2ème feuille sans supprimer les 1ères

[Collins]

Bonjour à tous

J'ai beau cherché un modèle, je ne trouve pas.
Alors je demande votre aide si il y a possibilité de le faire.
Toutes les explications sont sur le fichier exemple ci-joint
Merci

 

[sylvanu]

Bonjour Collins,
Un essai en PJ avec :

Sub Transfert()
Dim Source, Dest, DLSource%, DLDest%, Nb%, L%, C%
Application.ScreenUpdating = False
Set Source = Sheets("Feuil1")
Set Dest = Sheets("Feuil2")
'Mesure taille des deux tableaux
DLSource = Source.Range("A65500").End(xlUp).Row
DLDest = 1 + Dest.Range("A65500").End(xlUp).Row
'Nb comptera les nombre de lignes tranférées
Nb = 0
'Pour toutes les lignes sources
For L = 2 To DLSource
    'Si la date source n'existe pas dans destination
    If Application.CountIf(Dest.Range("A:A"), Source.Cells(L, "A")) = 0 Then
        'On copie les 5 cellules à la première ligne vide de destination
        For C = 1 To 5
            Dest.Cells(DLDest, C) = Source.Cells(L, C)
        Next C
        'On incrémente le pointeur d'écriture
        DLDest = DLDest + 1
        'On incrémente la quantité de lignes transférées
        Nb = Nb + 1
    End If
Next L
'Message final donnant la quantité de lignes transférées
MsgBox Nb & " lignes tranférées."
End Sub

J'ai supposé qu'une date n'apparaissait qu'une fois, une ligne de données par jour.

 

[Rouge]

Bonjour

Autre solution sans bouclage

Sub Completer()

    Dim f1 As Worksheet, f2 As Worksheet

    Dim DerLig_f1 As Long, DerLig_f2 As Long

    Dim DerDate_f1 As Date, DerDate_f2 As Date

    Dim PremDate_f1 As Range

    

    Application.ScreenUpdating = False

    Set f1 = Sheets("Feuil1")

    Set f2 = Sheets("Feuil2")

    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row

    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row

    DerDate_f1 = f1.Cells(DerLig_f1, "A")

    DerDate_f2 = f2.Cells(DerLig_f2, "A")

    Set PremDate_f1 = f1.Columns(1).Find(DerDate_f2) 'on recherche la dernière date de la feuille 2 dans la feuille 1

    If Not PremDate_f1 Is Nothing Then

        'si la date est trouvée, on copie tout ce qui est après cette date

        f1.Range(f1.Cells(PremDate_f1.Row + 1, "A"), f1.Cells(DerLig_f1, "E")).Copy f2.Cells(DerLig_f2 + 1, "A")

    End If

End Sub

 

[Collins]

Bonjour sylvanu, Rouge

Un grand merci à vous pour ces 2 solutions que je viens de tester sur mon fichier réel.
Ca marche à merveille.
Je vous souhaite une bonne soirée.

 

[Collins]

sylvanu

Je complète pour répondre à ce que tu as supposé.
Effectivement la date n'apparait qu'une fois dans les téléchargements.