Microsoft 365 Macro archivage

[Romain06]

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.

 

[sousou]

Bonjour romain.
Reste à savoir si tu veux copier tout le tableau,ou seulement les lignes contenant des données?

 

[Romain06]

Bonjour,
ne sachant pas que le cross-posting n'était pas accepté j'ai fais la demande en parallèle sur une autre plateforme où la solution à été trouvée. je me permets donc de la partager ici :

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


Mea culpa pour le double post et bonnes fêtes à tous.

 

[job75]

Bonjour Romain06, sousou,

Perso je n'ai rien contre le cross-posting si l'on donne les liens des divers forums.

Cela permet de comparer et d'améliorer éventuellement les solutions.

Par exemple ici moi j'utiliserais le fichier joint avec cette macro :

Sub Archiver()
Dim F1 As Worksheet, F2 As Worksheet, P As Range, Q As Range
Set F1 = Sheets("Feuil1")
Set F2 = Sheets("Archivage ") 'pourquoi un espace ???
Set P = F1.Range("A1", F1.UsedRange)
On Error Resume Next 'si aucune SpecialCell
Set Q = P.Offset(6).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Q Is Nothing Then If MsgBox("le tableau source est vide, voulez-vous quand même archiver ?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'à cause des liaisons externes
F2.Cells.Delete 'RAZ
P.EntireRow.Copy F2.[A1] 'copie tout y compris les hauteurs des lignes
F2.Range(P.Address) = P.Value 'copie les valeurs
If Not Q Is Nothing Then Q = "" 'RAZ
F2.Columns.AutoFit 'ajustement largeurs
F2.Activate 'facultatif
End Sub

A+