Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Microsoft 365 Macro archivage

Romain06

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

Pièces jointes

  • Fiche retour.xlsx
    184.1 KB · Affichages: 7
Solution
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...

Romain06

XLDnaute Nouveau
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

XLDnaute Barbatruc
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 :
VB:
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+
 

Pièces jointes

  • Fiche retour(1).xlsm
    193.2 KB · Affichages: 11

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…