Macro pour archiver sur une autre feuille

Bonjour à tous,
je suis débutant en macro et aimerais un coup de pouce.
Je souhaiterais créer une macro + un bouton qui permettra d'archiver les lignes du tableau de la "Feuil1" sur la feuille "archivage". Il s'agit donc d'un couper/coller de toutes les lignes du tableau dès lors que le bouton est pressé.
En espérant avoir été clair, je vous joints le document.
Merci d'avance.
Romain.

Sub 
Application.ScreenUpdating = False
Dim WsS As Worksheet, WsC As Worksheet
Dim Cel As Range, C As Range
Dim LigneAjout As Long

    Application.ScreenUpdating = False

    Set WsS = Worksheets("janvier") ' a adapter au nom de l'onglet
    Set WsC = Worksheets("Suivi Hotline") ' a adapter au nom de l'onglet

    For Each Cel In WsS.Range("A2:A" & WsS.Range("A" & Rows.Count).End(xlUp).Row)

        Set C = WsC.Columns(1).Find(Cel, , xlValues, xlWhole)
        LigneAjout = WsC.Range("A" & Rows.Count).End(xlUp).Row + 1

        If Not C Is Nothing Then
            Cel.Resize(, 16).Copy
            WsC.Range("A" & C.Row).PasteSpecial (xlPasteValues)
        Else
            Cel.Resize(, 16).Copy
            WsC.Range("A" & LigneAjout).PasteSpecial (xlPasteValues)
            LigneAjout = LigneAjout + 1
        End If

    Next Cel

    Application.CutCopyMode = False

    Set C = Nothing: Set WsS = Nothing: Set WsC = Nothing
Application.ScreenUpdating = True
End Sub

essaie ce code

Merci beaucoup Pyro206 pour ta réponse, la macro fonctionne.

Il me reste cependant une problématique, lorsque je tape une référence X dans la colonne A et que je presse mon bouton, cela fonctionne parfaitement. Je supprime ensuite ma référence et jusqu'ici tout va bien. En revanche lorsque je remets cette même référence, je souhaiterai qu'elle s'incrémente une seconde fois à la suite de ma feuille archive, dans le cas actuel elle ne fait que de mettre à jour la ligne déjà créée.

Cross-Posting...

Romain, tout neuf sur ce forum, tout neuf sur un autre...

Tu as lu les différentes chartes?

Notamment :

Ne postez pas la même question sur un autre forum pour éviter de faire perdre bêtement du temps aux membres sur un problème qui peut être déjà résolu sur l'autre forum. L'inverse est également valable, si vous avez déjà posé votre question sur un autre forum, ne créez pas un doublon sur ce forum (à moins d'avoir clôturé le sujet sur l'autre forum).

Pardon je n'avais pas vu ce point et cela ne se reproduira plus, la réactivité sur l'autre site étant moins bonne je me suis permis de créer un compte ici mon problème étant plus ou moins urgent.

Maintenant que tu as fais la police du web, aurais tu par hasard une réponse à apporter ?

Sub test()

Application.ScreenUpdating = False

Dim WsS As Worksheet, WsC As Worksheet

Dim Cel As Range, C As Range

Dim LigneAjout As Long

Application.ScreenUpdating = False

Set WsS = Worksheets("Feuil1") ' a adapter au nom de l'onglet

Set WsC = Worksheets("Archivage ") ' a adapter au nom de l'onglet

For Each Cel In WsS.Range("A7:A" & WsS.Range("A" & Rows.Count).End(xlUp).Row)

Set C = WsC.Columns(1).Find(Cel, , xlValues, xlWhole)

LigneAjout = WsC.Range("A" & Rows.Count).End(xlUp).Row + 1

If Not C Is Nothing Then

' Cel.Resize(, 16).Copy

' WsC.Range("A" & C.Row).PasteSpecial (xlPasteValues)

' Else

Cel.Resize(, 16).Copy

WsC.Range("A" & LigneAjout).PasteSpecial (xlPasteValues)

LigneAjout = LigneAjout + 1

End If

Next Cel

Application.CutCopyMode = False

Set C = Nothing: Set WsS = Nothing: Set WsC = Nothing

Application.ScreenUpdating = True

End Sub

avec cette correction cela convient il mieux ,

j'ai désactiver la condition de contrôlé d'exitance supprime les guillemet si toute fois tu devais en avoir besoin 😊

Pyro, encore une fois merci pour le temps accordé sur mon problème. Je sens qu'on approche du but. Le seul problème est qu'avec ta rectification la ligne n'est plus reportée sur ma feuille archive. Pas de message d'erreur de la macro mais rien sur la feuille archive. As-tu une idée ?

Re-,

Non rancunier, mais ta remarque n'était pas la plus adaptée...

Essaie :

Sub archive()
Dim ShArchiv As Worksheet, ShOrig As Worksheet
Set ShOrig = Sheets("Feuil1"): Set ShArchiv = Sheets("Archivage")
Dim Plg As Range
With ShOrig
    If .Range("A7") <> "" Then 'si la cellule A7 contient des données
        Set Plg = .Range("A7:G" & .Cells(Rows.Count, "A").End(xlUp).Row) 'détermination de la plage à copier
        Plg.Copy 'copie de la plage
        ShArchiv.Cells(Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues 'collage spécial uniquement les valeurs
        Plg.SpecialCells(xlCellTypeConstants, 23).ClearContents 'effacement des données intiales sauf les formules
    End If
End With
End Sub

Ta solution fonctionne. Merci à vous deux.

Bonjour,

Et le gars, il me colle un -1 alors que je lui donne la solution

C'est beau, la jeunesse...

Cousinhub apparement tu as du temps à perdre. D’une part tu viens me faire ton petit point de moral alors qu’il est évident que je ne connais pas les règles du site. Un peu de tolérance ne fait pas de mal surtout par les temps qui cours. Maintenant je ne pense que ce n’est ni le moment ni l’endroit pour faire une petite gueguerre puéril que tu as l’air de vouloir mener. Pour ce qui est du -1 qui a l’air de changer fondamentalement ton existence, je l’ai mis sur ton commentaire que j’ai trouvé condescendant et inapproprié et non sur ta réponse (je t’ai remercié pour celle-ci) mais peut être vas tu me sortir une règle comme quoi une personne qui trouve une solution à un problème Excel a le droit d’être une personne discutable.