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

Collins · 9 Décembre 2020

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

Rouge · 9 Décembre 2020

Bonjour

Autre solution sans bouclage

VB:

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...

sylvanu · 9 Décembre 2020

Bonjour Collins,
Un essai en PJ avec :

VB:

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 · 9 Décembre 2020

Bonjour

Autre solution sans bouclage

VB:

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 · 9 Décembre 2020

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 · 9 Décembre 2020

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.

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

Collins

XLDnaute Occasionnel

Pièces jointes

Rouge

sylvanu

XLDnaute Barbatruc

Pièces jointes

Rouge

XLDnaute Impliqué

Collins

XLDnaute Occasionnel

Collins

XLDnaute Occasionnel

Discussions similaires