Macro pour archiver des données

[Paul Templeraud]

Bonjour à tous,

Je souhaiterai réaliser une macro pour pouvoir archiver des données qui seraient rentrées dans un tableau de ma première feuille excel vers un autre tableau de cette feuille qui servirait d'archive. Je travail en ligne et je souhaiterai que dès que je clique sur un bouton archiver que la ligne se déplace dans l'archive.

Mon idée aussi serait de pouvoir récupérer le jour de l'archivage à chaque fois que j'archive mes données.

Débutant en VBA, je suis vraiment perdu, je fais des tests avec les infos que j'ai pu trouver dans les autres discussions, mais sans réussite

Merci pour le temps que vous y consacrerez...

Paul

PS: je vous joins mon fichier de travail pour mieux comprendre.

 

[job75]

Bonjour Paul Templeraud, bienvenue sur XLD,

Ce n'est pas clair, quel est le rapport entre la 1ère et la 2ème feuille ?

Pas clair non plus l'histoire de la "ligne qui se déplace" !

Que voulez-vous faire exactement ?

A+

 

[Paul Templeraud]

Bonjour, merci pour votre retour,

J'ai modifié le fichier, j'ai laissé une feuille en trop.

La macro se passe uniquement sur la feuille "Fiche Vierge".

J'ai deux tableaux qui seront rentré à la main avec des infos différentes :

- Le tableau de gauche va regrouper un compte rendu d'action (Etude de projet, Travaux, Mise en service, etc). Lorsque je vais remplir ma première ligne avec l'action, je vais lui définir un état (A faire, en cours, terminé), lorsque je clique sur le bouton "archiver" je veux que toutes les actions avec le statu "Terminé", ce couper/coller dans le tableau en dessous.

- Le tableau de droite va lui regrouper des commentaires de suivi de projet, c'est sensiblement la même demande que pour le tableau de gauche sauf que lorsque je clique sur le bouton toute les lignes avec du contenu ce couper/coller dans le tableau en dessous.

J'espère avoir été plus clair.

Merci pour votre future réponse .

 

[job75]

Re,

A placer dans le code de la feuille (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_Change(ByVal Target As Range)
'maintient 2 lignes vides avant les tableaux Archives
Dim derlig1&, derlig2&, derlig, cc%
derlig1 = ListObjects(1).Range.Row + ListObjects(1).Range.Rows.Count - 1
derlig2 = ListObjects(2).Range.Row + ListObjects(2).Range.Rows.Count - 1
derlig = IIf(derlig1 > derlig2, derlig1, derlig2)
Application.EnableEvents = False
Application.DisplayAlerts = False
derlig1 = Cells.SpecialCells(xlCellTypeLastCell).Row 'denière cellule de la feuille
If [Archives1].Row - derlig <> 3 Then
    cc = ListObjects(1).Range.Columns.Count
    [Archives1].Resize(derlig1 - [Archives1].Row + 1, cc).Cut Cells(derlig + 3, [Archives1].Column)  'couper-coller
    [Archives1].Resize(, cc).Merge 'refusionne
End If
If [Archives2].Row - derlig <> 3 ThenEditer
    cc = ListObjects(2).Range.Columns.Count
    [Archives2].Resize(derlig1 - [Archives2].Row + 1, cc).Cut Cells(derlig + 3, [Archives2].Column) 'couper-coller
    [Archives2].Resize(, cc).Merge 'refusionne
End If
Application.EnableEvents = True
End Sub

Sub Archiver()
If IsError(Application.Caller) Then Exit Sub
Dim n As Byte
Application.ScreenUpdating = False
Application.EnableEvents = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
n = IIf(Shapes(Application.Caller).TopLeftCell.Column > ListObjects(2).Range.Column, 2, 1)
With Range("Archives" & n).Offset(1).Resize(ListObjects(n).Range.Rows.Count, ListObjects(n).Range.Columns.Count)
    .Value = ListObjects(n).Range.Value 'copie les valeurs
    .Borders.Weight = xlThin 'bordures
    With .Offset(.Rows.Count).Resize(Rows.Count - .Rows.Count - .Row + 1) 'en dessous
        .ClearContents 'RAZ
        .Borders.LineStyle = xlNone
    End With
End With
End Sub

Les tableaux sources doivent être organisés en tableaux Excel.

Notez les cellules nommées Archives1 et Archives2.

Fichier joint.

A+

 

[Paul Templeraud]

Merci beaucoup, c'est ce que je voulais.

Sans vouloir abuser j'aurais voulu que pour le tableau de gauche uniquement les lignes comportant le mot "Terminé" soit archivé.
De plus, j'aurai voulu que les lignes après avoir étaient archivé disparaisse du premier tableau et s'incréments les unes après les autres dans les tableaux archives.

Mais c'est déjà très bien, merci beaucoup.

 

[job75]

Re,

Je viens de modifier un peu la 1ère macro de mon post #4 : les 2 tableaux sont traités séparément, c'est mieux.

Pour vos nouvelles demandes ce n'est pas très clair, joignez un fichier montrant les données avant et après archivage, pour chaque tableau.

A+

 

[Paul Templeraud]

Re,

J'ai compléter mon fichier de base avec un exemple de avant / après.

Merci pour votre future réponse

 

[job75]

Re,

Pour cette solution il faut que les tableaux "Archives" soient placés dans les mêmes colonnes que les tableaux sources.

La macro des boutons :

Sub Archiver()
If IsError(Application.Caller) Then Exit Sub
Dim n As Byte, col%, cc%, i&, r As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
n = IIf(Shapes(Application.Caller).TopLeftCell.Column > ListObjects(2).Range.Column, 2, 1)
With ListObjects(n).Range
    col = Range("Archives" & n).Column
    cc = .Columns.Count
    For i = .Rows.Count To 2 Step -1
        If .Cells(i, 2) <> "" And IIf(n = 1, .Cells(i, 3) = "Terminé", True) Then
            Set r = Cells(Rows.Count, col).End(xlUp)(2).Resize(, cc)
            .Rows(i).Copy r
            r = r.Value 'supprime les formules
            r.Interior.ColorIndex = xlNone
            r.Borders.Weight = xlThin
            r.Borders.ColorIndex = xlAutomatic
            .Rows(i).Delete xlUp
        End If
    Next
End With
Application.EnableEvents = True
Worksheet_Change [A1] 'lance la macro
End Sub

Fichier (2).

A+

 

[Paul Templeraud]

C'est parfait merci beaucoup.

Dernière question après je ne t'embête plus, si je créé une copie de cette feuille la macro ne fonctionne plus, as tu une astuce rapide ?

Merci encore 1000 fois !

 

[job75]

Re,

Si l'on copie la feuille par la commande "Déplacer ou copier" les macros sont bien sûr copiées.

Il suffit alors d'affecter aux boutons la bonne macro.

A+

 

[Paul Templeraud]

Parfait, merci beaucoup pour ton temps.

 

[job75]

Bonjour Paul, le forum,

La copie des codes alourdit inutilement le fichier, il vaut mieux les placer dans ThisWorkbook :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'maintient 2 lignes vides avant les tableaux Archives
If Sh.ListObjects.Count < 2 Then Exit Sub
Dim derlig1&, derlig2&, derlig, cc%
derlig1 = Sh.ListObjects(1).Range.Row + Sh.ListObjects(1).Range.Rows.Count - 1
derlig2 = Sh.ListObjects(2).Range.Row + Sh.ListObjects(2).Range.Rows.Count - 1
derlig = IIf(derlig1 > derlig2, derlig1, derlig2)
Application.EnableEvents = False
Application.DisplayAlerts = False
derlig1 = Sh.Cells.SpecialCells(xlCellTypeLastCell).Row 'denière cellule de la feuille
If [Archives1].Row - derlig <> 3 Then
    cc = Sh.ListObjects(1).Range.Columns.Count
    [Archives1].Resize(derlig1 - [Archives1].Row + 1, cc).Cut Cells(derlig + 3, [Archives1].Column)  'couper-coller
    [Archives1].Resize(, cc).Merge 'refusionne
End If
If [Archives2].Row - derlig <> 3 Then
    cc = Sh.ListObjects(2).Range.Columns.Count
    [Archives2].Resize(derlig1 - [Archives2].Row + 1, cc).Cut Cells(derlig + 3, [Archives2].Column) 'couper-coller
    [Archives2].Resize(, cc).Merge 'refusionne
End If
Application.EnableEvents = True
End Sub

Sub Archiver()
If IsError(Application.Caller) Then Exit Sub
Dim n As Byte, col%, cc%, i&, r As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
n = IIf(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Column >= ActiveSheet.ListObjects(2).Range.Column, 2, 1)
With ActiveSheet.ListObjects(n).Range
    col = Range("Archives" & n).Column
    cc = .Columns.Count
    For i = .Rows.Count To 2 Step -1
        If .Cells(i, 2) <> "" And (.Cells(i, 3) = "Terminé" Or n = 2) Then
            Set r = Cells(Rows.Count, col).End(xlUp)(2).Resize(, cc)
            .Rows(i).Copy r
            r = r.Value 'supprime les formules
            r.Interior.ColorIndex = xlNone
            r.Borders.Weight = xlThin
            r.Borders.ColorIndex = xlAutomatic
            .Rows(i).Delete xlUp
        End If
    Next
End With
Application.EnableEvents = True
Workbook_SheetChange ActiveSheet, [A1] 'lance la macro
End Sub

Fichier (3).

Bonne journée.

 

[Paul Templeraud]

Merci encore !