XL 2019 Copier coller plage variable

Sub ArchiverRapport()
    Dim source As Range
    With ThisWorkbook
        'Définition de la source des données
        With .Sheets("Rapport").Range("A3").CurrentRegion
            ' Tableau de A3 sans ses lignes d'entêtes
            Set source = .Offset(3).Resize(.Rows.Count - 3)
        End With
       
        With .Sheets("Archive").Cells(Rows.Count, 1).End(xlUp)(2)
            'Coller les valeurs en fin de tableau en fonction du nombre de lignes et colonne de la source
            .Resize(source.Rows.Count, source.Columns.Count).Value = source.Value
        End With
    End With
    MsgBox source.Rows.Count & " ligne(s) archivée(s)", vbInformation, "Archivage"
End Sub

Tableaux structurés Excel

Tableaux structurés Excel

fauconnier.developpez.com

Cliquez pour agrandir...

duplaly à dit:

Bonjour
Je joins une copie de mon fichier et voici ce que j'essaye de faire.
Je veux archiver les données de la feuille "Rapport" vers la feuille "Archive" tout en inscrivant la date "colonne A" sur chaque ligne jusqu'à la dernière ligne remplie.
À noter que les données dans la feuille "Rapport" sont variables à chaque archivage. J'aimerais que la date soit recopiée en fonction du nombre de lignes remplies.

Chaque archivage doit se coller en dessous de la feuille "Archive".

Merci à l'avance pour votre aide!

Cliquez pour agrandir...

Sub archiver()
    Dim derlg&
    If IsNumeric(Application.Match(Feuil1.[k2], Feuil2.[A:A], 0)) Then MsgBox "Archive déjà existante à cette date.", , "Information": Exit Sub
    derlg = Feuil2.Cells(Feuil2.Rows.Count, "B").End(xlUp).Row + 1
    Feuil1.UsedRange.Offset(3).Resize(Feuil1.UsedRange.Rows.Count - 3).Copy Feuil2.Range("b" & derlg)
    Feuil2.Range("a" & derlg & ":a" & Application.CountA(Feuil2.[b:b]) + 1) = CDate(Feuil1.[k2])
End Sub

Jacky67 à dit:

Bonsoir à tous
Un exemple en pj avec ce code

VB:

Sub archiver()
    Dim derlg&
    If IsNumeric(Application.Match(Feuil1.[k2], Feuil2.[A:A], 0)) Then MsgBox "Archive déjà existante à cette date.", , "Information": Exit Sub
    derlg = Feuil2.Cells(Feuil2.Rows.Count, "B").End(xlUp).Row + 1
    Feuil1.UsedRange.Offset(3).Resize(Feuil1.UsedRange.Rows.Count - 3).Copy Feuil2.Range("b" & derlg)
    Feuil2.Range("a" & derlg & ":a" & Application.CountA(Feuil2.[b:b]) + 1) = CDate(Feuil1.[k2])
End Sub

Cliquez pour agrandir...

duplaly à dit:

Hello

Jacky
Je ne suis pas loin de la solution avec ton code.
Possible de coller juste valeur. Présentement, le code copie tout et ce n'est pas bon pour moi.

Merci

Cliquez pour agrandir...

Sub archiver()
    Dim derlg&
    If IsNumeric(Application.Match(Feuil1.[k2], Feuil2.[A:A], 0)) Then MsgBox "Archive déjà existante à cette date.", , "Information": Exit Sub
    derlg = Feuil2.Cells(Feuil2.Rows.Count, "B").End(xlUp).Row + 1
    Feuil1.UsedRange.Offset(3).Resize(Feuil1.UsedRange.Rows.Count - 3).Copy
    Feuil2.Range("b" & derlg).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Feuil2.Range("a" & derlg & ":a" & Application.CountA(Feuil2.[b:b]) + 1) = CDate(Feuil1.[k2])
    Application.CutCopyMode = False
End Sub

Jacky67 à dit:

Re..
Ben.. il n'y a pas de formules......
Néanmoins, ceci

VB:

Sub archiver()
    Dim derlg&
    If IsNumeric(Application.Match(Feuil1.[k2], Feuil2.[A:A], 0)) Then MsgBox "Archive déjà existante à cette date.", , "Information": Exit Sub
    derlg = Feuil2.Cells(Feuil2.Rows.Count, "B").End(xlUp).Row + 1
    Feuil1.UsedRange.Offset(3).Resize(Feuil1.UsedRange.Rows.Count - 3).Copy
    Feuil2.Range("b" & derlg).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Feuil2.Range("a" & derlg & ":a" & Application.CountA(Feuil2.[b:b]) + 1) = CDate(Feuil1.[k2])
    Application.CutCopyMode = False
End Sub

Et ajout de :
**Application.CutCopyMode = False

Cliquez pour agrandir...

duplaly à dit:

Bel avancement pour moi. il faut juste traiter la date.

Cliquez pour agrandir...

Sub ArchiverRapport()
    Dim source As Range
    With ThisWorkbook
        'Définition de la source des données
        With .Sheets("Rapport").Range("A3").CurrentRegion
            ' Tableau de A3 sans ses lignes d'entêtes
            Set source = .Offset(3).Resize(.Rows.Count - 3)
        End With

        With .Sheets("Archive").Cells(Rows.Count, 1).End(xlUp)(2)
           .Offset(, 1).Resize(source.Rows.Count, source.Columns.Count + 1).Value = source.Value
           .Resize(source.Rows.Count, 1).Value = Date
        End With
    End With
    MsgBox source.Rows.Count & " ligne(s) archivée(s)", vbInformation, "Archivage"
End Sub

https://www.excel-downloads.com/threads/copier-coller-plusieurs-fois.20053638/

Cliquez pour agrandir...