VBA - Transfert de lignes avec un critère vers TB autre feuille

Bonjour

Après deux jours de galère (et une besoin assez urgent), je me décide à venir sur le site car j'ai bon espoir qu'une bonne âme acceptera de me filer un coup de mains ! En effet, complètement autodidacte sur le sujet et n'ayant pas fait de macro depuis 3 ans, je m'y remet et c'est compliqué pour moi ! J'ai parcouru le forum en amont de mon message et j'ai vu des post sur ce sujet et j'ai bien essayé d'adapter le code à mon besoin mais soit ça ne fait pas complètement ce que je veux, soit ça bug !
Je sais que pour un expert VBA ce sera de la rigolade mais moi j'en chie ! Ça m'intéresse et j'ai envie de comprendre et d'avancer dans mon cheminement mais seule c'est pas évident ! Besoin d'expertise pour comprendre où le bât blesse !

Voilà, j'ai un fichier Excel avec plusieurs feuilles, dont deux sur lesquelles je souhaite agir.
La 1ère se nomme "Plan documentaire", la seconde se nomme "Archives". Les deux comportent un tableau de même structure.
Je souhaite simplement créer une macro que j'affecterai à un bouton pour permettre aux utilisateurs d'archiver dans le tableau de l'onglet "Archives" toutes les lignes présentant le critère "Archivé" du tableau de l'onglet "Plan documentaire". Les lignes ainsi copiées dans l'onglet "Archives" devront être supprimées du tableau de l'onglet "Plan documentaire".
Avec un message box indiquant si c'est possible le nombre de lignes archivées une fois l'opération réalisée.

Idéalement j'aimerai avoir la possibilité d'un deuxième bouton macro sur la feuille "Archives" pour restaurer une ligne particulière (archivée par erreur par exemple) vers le tableau d'origine sur la feuille "Plan documentaire" ! (pas utile qu'elle reprenne sa place initiale)

Mes difficultés aujourd'hui avec les différents codes testés
- soit ça ne colle pas les lignes au bon endroit (en dessous de mon tableau existant et pas dedans.
- soit ne copie que la ligne de titre mais pas les lignes contenant le critère "Archivés"
- soit copie bien mais affiche l'erreur VALEUR car les lignes copiées comportent des formules
- soit il ne supprime pas les lignes dans l'onglet source

Bref, je me sens nulle en écrivant tout cela !

Voici le dernier bout de code utilisé et le fichier en pièce jointe :

Sub Transfert()
Dim LastLig As Long
Dim cDest As Range

Application.ScreenUpdating = False
With ThisWorkbook
'cDest: La celllule de destination: première cellule vide de la colonne A de Archives
With .Worksheets("Archives")
Set cDest = .Cells(.Rows.Count, "A").End(xlUp)(2)
End With
With .Worksheets("Plan documentaire")
'Enlève l'éventuel filtre automatique
.AutoFilterMode = False
'LastLig, ligne de la dernière cellule remplie de colonne A de Plan documentaire
LastLig = .Cells(.Rows.Count, "I").End(xlUp).Row
'On fait un filtre automatique sur la colonne I de Plan documentaire avec comme critère "Archivé"
.Range("I11:I" & LastLig).AutoFilter field:=1, Criteria1:="Archivé"
'Si au moins une ligne résultat du filtre (en plus de la ligne 1 des titres)
If .Range("A1:A" & LastLig).SpecialCells(xlCellTypeVisible).Count > 1 Then
With .Range("A1:A" & LastLig).SpecialCells(xlCellTypeVisible).EntireRow
'On copie toutes les lignes visibles vers cDest (sauf la ligne des titres)
.Copy cDest
'on supprime toutes les lignes visibles (sauf la ligne des titres)
.Delete
End With
End If
'on vide notre variable cDest
Set cDest = Nothing
'On enlève le filtre automatique
.AutoFilterMode = False
End With
End With
End Sub

Bonjour, il faut faire une boucle de bas en haut puisque vous allez supprimer des lignes.

Sub ARCHIVER()
'
Dim derligne As Long
'on trouve le nombre de lignes utilisées de l'onglet "PLan"
derligne = Worksheets("Plan documentaire").Range("A65536").End(xlUp).Row

'On fait une boucle de la dernière ligne de l'onglet "Plan" jusqu'à la ligne 11 
For X = derligne To 11 Step -1

'On note le numéro de la première ligne vide de l'onglet archives
ligarchive = Worksheets("Archives").Range("A65536").End(xlUp).Row + 1

'On test le contenu de la colonne I ligne par ligne pour vérifier si contient "Archivé"
If Worksheets("Plan documentaire").Range("I" & X).Value = "Archivé" Then

'Si oui alors la plage de (A à P) de l'onglet Archives est égàle à la plage de (A à P) de l'onglet "Plan"
Worksheets("Archives").Range("A" & ligarchive & ":P" & ligarchive).Value = Worksheets("Plan documentaire").Range("A" & X & ":P" & X).Value

'On supprime la ligne qui a été copiée 
Rows(X).Delete Shift:=xlUp
End If

'On continue le test en remontant d'une ligne.
Next X

End Sub

Bonjour Xmenpl

Tout d'abord, merci d'avoir pris de votre temps pour me répondre. Vraiment ça fait plaisir !

Alors j'ai testé votre code et tout se passe bien si ce n'est qu'il copie les données à l'extérieur (juste en dessous) de mon tableau , mis en forme "sous forme de tableau".

Du coup il copie uniquement les valeurs, ce n'est pas grave si je perds les formules mais j'aimerai bien garder le même tableau et la même mise en forme.

Est-ce possible selon vous ?

Puis-je aussi ajouter un message box pour informer de la fin du traitement ?

Je ne voudrai pas abuser, c'est déjà précieux pour moi ce que vous m'avez envoyé.

Alors me revoilà, j'ai avancé...un peu..

Pour ne pas voir l'exécution de la macro, j'ai ajouté en début et fin Screen updating False/True (car sinon on voit la suppression des lignes une à une)

j'ai ajouté un msgbox qui fonctionne bien dans un nouveau module qui appelle la macro à s'éxécuter si la réponse est oui

en revanche le msgbox censé compter les lignes archivées à la fin NE COMPTE RIEN du tout. Peut-être est-ce parce que je ne l'ai pas mis dans le même module. Je ne sais pas. Qui plus est le transfert des lignes à archiver se fait après validation du dernier msgbox, ce qui n'est pas logique du tout. Je pense vraiment que c'est mal placé !!

Pouvez-vous m'aider à nouveau svp ?

Bonjour à tous, Salut Xmenpl,

Voici une proposition qui repose sur 2 tableaux structurés, l'un sur la feuille "Plan documentaire" nommé "Plan" et l'autre sur la feuille "Archives" nommé "Archives" :

Sub ARCHIVER()
dim rDelete as range
with range("Plan")
    t = .value
    For i = 1 to .rows.count
        If .listobject.listcolumns("Etat")(i, 1) = "Archivé" Then
            n = n + 1
            for k = 1 to .columns.count
                t(n, k) = t(i, k)
            next k
            if rDelete is nothing then set rDelete = .rows(i) else set rDelete = union(rDelete, .rows(i))
        end if
    next i
end with
if n > 0 then
    range("Archives").listobject.listrows.add.range.resize(n, ubound(t, 2)).value = t
    rDelete.delete xlup
    sPluriel = iif(n = 1, "", "s")
    msgbox "Il y a " & n & " ligne" & sPluriel & " archivée" & sPluriel & "."
else
    msgbox "Aucune donnée n'a été archivée !", vbexclamation, "Défaut de correspondance"
end if
End Sub

Cdlt,

Bonjour

merci pour ta proposition, mais ta macro bug sur mon fichier (voir capture)

si tu sais pourquoi ?

Cordialement

J'ai oublié un détail, en espérant que ça s'exécute bien...

Sub ARCHIVER()
dim rDelete as range
with range("Plan documentaire")
    t = .value
    For i = 1 to .rows.count
        If .listobject.listcolumns("Etat").databodyrange(i, 1) = "Archivé" Then
            n = n + 1
            for k = 1 to .columns.count
                t(n, k) = t(i, k)
            next k
            if rDelete is nothing then set rDelete = .rows(i) else set rDelete = union(rDelete, .rows(i))
        end if
    next i
end with
if n > 0 then
    range("Archives").listobject.listrows.add.range.resize(n, ubound(t, 2)).value = t
    rDelete.delete xlup
    sPluriel = iif(n = 1, "", "s")
    msgbox "Il y a " & n & " ligne" & sPluriel & " archivée" & sPluriel & "."
else
    msgbox "Aucune donnée n'a été archivée !", vbexclamation, "Défaut de correspondance"
end if
End Sub

Sinon, tu as bien les données sous forme de tableaux structurés nommés "Plan documentaire" et "Archives" ?

Et bien, je suis impressionnée ! Ça marche du feu de Dieu !

Alors effectivement de mon côté je n'avais pas nommé mes tableaux. C'est chose faite.

Juste une petite chose si c'est faisable facilement, je ne sais pas.'?).

- les lignes archivées se positionnent en fin de tableau, il n'y a pas moyen de faire en sorte qu'elles s'incrémentent les unes en dessous des autres sous la ligne de titre, ce serait plus joli ! (?) - voir 1ere capture

Encore une chose si tu peux m'aider encore une fois pour boucler ça vite et bien sans quoi je risque de chercher encore plusieurs jours (mais c'est comme ça qu'on apprend aussi !), je voudrai mettre en place un bouton macro qui permette de restaurer une ou plusieurs lignes archivées sur la feuille Archives vers le tableau de la feuille Plan documentaire. Donner la possibilité à l'utilisateur s'il s'est trompé de faire un retour arrière et ainsi restaurer des lignes archivées.

Pour le bouton, je sais (lol), le plus compliqué c'est la macro...!!

J'ai bien un bout de code qui fait le job mais par un double clic sur une ligne précise donc je vois deux problèmes éventuels à cette démarche :

- trop contraignant si plusieurs lignes à restaurer d'un coup ! (on ne va pas double cliquer sur autant de lignes qu'on veut archiver !)

- trop risqué si un utilisateur fait un double clic par erreur --> où alors il faudrait inclure un msgbox qui confirmerait la demande de restauration par l'utilisateur !

Je ne sais pas ce que tu ferais toi ? Est-ce que mon raisonnement est mauvais ? voir 2nde capture

2nde capture, pour la macro permettant la restauration de lignes archivées dans le fichier source..à la suite de la dernière ligne non vide du tableau.

je pense aussi qu'il y aura un problème quand le filtre affichera plus de résultats !! non ?

En espérant que tu puisses encore m'apporter ton aide. Oh combien précieuse !

Bien cordialement.

Bonjour,

En fait, l'idée c'est qu'on commence avec une base vide normalement. Sinon, le collage à la suite est tout à fait normal.

Voici un essai qui prévoit de coller des lignes juste après les titres si le tableau contient une première ligne vide (ou plutôt si la première cellule est vide) :

Sub ARCHIVER()
dim rDelete as range
with range("Plan documentaire")
    t = .value
    For i = 1 to .rows.count
        If .listobject.listcolumns("Etat").databodyrange(i, 1) = "Archivé" Then
            n = n + 1
            for k = 1 to .columns.count
                t(n, k) = t(i, k)
            next k
            if rDelete is nothing then set rDelete = .rows(i) else set rDelete = union(rDelete, .rows(i))
        end if
    next i
end with
if n > 0 then
    with range("Archives")
        if not .listobject.databodyrange is nothing and .cells(1, 1) = "" then
            .rows(1).resize(n, ubound(t, 2)).value = t
        else
            .listobject.listrows.add.range.resize(n, ubound(t, 2)).value = t
        end if
    end with
    rDelete.delete xlup
    sPluriel = iif(n = 1, "", "s")
    msgbox "Il y a " & n & " ligne" & sPluriel & " archivée" & sPluriel & "."
else
    msgbox "Aucune donnée n'a été archivée !", vbexclamation, "Défaut de correspondance"
end if
End Sub

Pour le reste, l'idée du double clic est pas mal. Il faut juste prévoir un message avant éventuellement.

Sinon, je vais essayer un code pour restaurer plusieurs lignes d'un coup.

Cdlt,

Bonsoir 3GB

Ravie de ta réponse.

Je vais tester ça de mon côté.

j'ai cherché toute la sainte journée pour ma macro de restauration..en vain. Pour le moment !

Bien à toi.

3GB, c'est nickel ! Je viens de tester ta dernière version ! Tu assures !Ton code est propre, net et clair et beaucoup plus réduit que d'autres !

Je suis admirative. Ca me fascine.

Encore merci pour le temps que tu consacres à ma demande. Si tu trouves pour le bouton "restauration" ce sera la "cerise sur le gâteau" parce que c'est déjà très bien !

Les utilisateurs n'auront qu'à archiver à la mano !

Belle soirée.

MK