Fonction : Archive

Bonjour à tous,

Je fais appel à vos compétences car je me débrouille assez bien avec les fonctions Excel mais plutôt mal avec les macros et je n'arrive vraiment pas à créer la macro qui m’intéresse.

Alors voila, pour terminer mon projet de suivie de dossier, il me manque juste la création d'une macro pour archiver les dossiers.

Le fichier étant trop lourd ; il est téléchargeable ici : https://we.tl/t-VZdCMz00vi

Pour information, nos dossiers sont catégorisé de cette façon : année-nombre avec par exemple pour le 1ier dossier de 2019 : 19001.

Ainsi ce que je voudrais c'est une macro qui exécute les actions suivante :

• L'utilisateur entre le dossier à archiver dans l'onglet "saisie" cellule A1 par exemple : 19001
• l'utilisateur appuis sur le bouton "archiver"
• La macro trouve dans la colonne A le N° du fichier saisie et coupe la ligne entière pour venir la coller dans la page d'archive correspondante :

(par exemple ; à la ligne 900)

- la macro trie par N° de dossier (pour que le dossier ne soit plus à la ligne 900)

J'espère avoir été clair dans mes propos et j'espère que l'un de vous saura trouver une solution !

Merci

Mathis

Bonjour,

Un essai ...

Note : sur la feuille de destination, la colonne A ne devrait pas contenir un liste ne numéros inutiles comme sur le fichier soumis ...

Sub Archiver()
Dim x As Integer                    ' déclaration des variables
Dim Dl As Integer, Wsdl As Integer
Dim Dc As Integer
Dim Ws As Worksheet

    Application.ScreenUpdating = False
    With Worksheets("Saisie")
        Dc = .Cells(3, Columns.Count).End(xlToLeft).Column  ' dernière ligne de la feuille Saisie
        Set Ws = Worksheets("20" & Left(.Cells(1, "A"), 2)) ' détermine le nom de la feuille de destination
        Wsdl = Ws.Cells(Rows.Count, "A").End(xlUp).Row + 1  ' dernière ligne de la feuille de destination

        For x = 4 To .Cells(Rows.Count, "B").End(xlUp).Row  ' boucle pour trouver la ligne de la donnée recherchée
            If .Cells(x, "A") = .Cells(1, "A") Then         ' comparaison
                        ' si trouvé, copie dans la feuille de destination
                .Range(.Cells(x, 1), .Cells(x, Dc)).Copy Destination:=Ws.Range(Ws.Cells(Wsdl, 1), Ws.Cells(Wsdl, Dc))
                        ' supprime le ligne archivée
                .Range(.Cells(x, 1), .Cells(x, Dc)).Delete Shift:=xlUp
                Exit For        ' sort de la boucle FOR
            End If
            If x = .Cells(Rows.Count, "B").End(xlUp).Row Then   ' si pas trouvé ... message et fin de la macro
                MsgBox " Le numéro recherché n'a pas été trouvé où il n'a pas de données en colonne B !"
                Exit Sub
            End If
        Next x

        Ws.Sort.SortFields.Clear        ' vide l'éventuel dernier trie sur la feuille de destination
                                        ' prépare le trie sur la feuille de destination
        Ws.Sort.SortFields.Add2 Key:=Ws.Range(Ws.Cells(4, "A"), Ws.Cells(Wsdl, "A")), _
                                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        With Ws.Sort            ' applique le trie sur la feuille de destination
            .SetRange Ws.Range(Ws.Cells(3, 1), Ws.Cells(Wsdl, Dc))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub

ric

Bonjour,

Merci de m'avoir répondu,

Je testerais ce soir

merci

ric

Bonsoir,

Cela a l'air de marcher parfaitement !

Un grand merci !

ric