Tri numérique puis alphabétique après un couper-coller

Bonjour à tous,

Je vous sollicite pour un soucis que je rencontre dans mon code VBA.

Je dispose d'un classeur excel avec 3 feuilles :

• Actif
• Perdu
• En veille

J'ai réalisé la première partie de mon code qui me permet de couper/coller une ligne (d’environ 15 colonnes) de la feuille "actif" vers une autre feuille en fonction d'une donnée d'une cellule "Q"(perdu ou en veille).

Si la cellule Q indique en veille, alors la ligne et coupée et collée dans la feuille "en veille".

Jusque là, tout fonctionne.

En revanche, j'aimerais que la feuille dans laquelle arrive cette ligne soit triée selon 2 critères successifs.

Premièrement, par un critère colonne B (numérique) puis un critère colonne A (alphabétique).

Sauriez-vous comment intégrer ce tri dans le code ci-dessous ?

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, [Q3:Q250]) Is Nothing Then 'plage à adapter
    If Target.Count > 1 Then Exit Sub 'si on modifie plusieurs cellules simultanément
    If UCase(Target) = "EN VEILLE" Then
        nouvlig = Sheets("EN VEILLE").Cells(Rows.Count, 1).End(xlUp).Row + 1 'index de la première ligne vide dans "Archives"
        Cells(Target.Row, 1).Resize(1, 26).Copy
        Sheets("EN VEILLE").Cells(nouvlig, 1).Resize(1, 26).PasteSpecial
        Application.EnableEvents = False 'désactiver les événements
        Cells(Target.Row, 1).EntireRow.Delete
        Application.EnableEvents = True
    End If
    On Error Resume Next
If Not Intersect(Target, [Q3:Q250]) Is Nothing Then 'plage à adapter
    If Target.Count > 1 Then Exit Sub 'si on modifie plusieurs cellules simultanément
    If UCase(Target) = "PERDU" Then
        nouvlig = Sheets("PERDU").Cells(Rows.Count, 1).End(xlUp).Row + 1 'index de la première ligne vide dans "Archives"
        Cells(Target.Row, 1).Resize(1, 26).Copy
        Sheets("PERDU").Cells(nouvlig, 1).Resize(1, 26).PasteSpecial
        Application.EnableEvents = False 'désactiver les événements
        Cells(Target.Row, 1).EntireRow.Delete
        Application.EnableEvents = True
    End If
End If
End If
End Sub

Merci par avance,

Juju

Bonjour,

As-tu un fichier pour tester différentes approches ?

Je voudrais tester si une procédure événementielle sur la feuille de destination ne permettrait pas de répondre à la question.

Sinon, il faudra créer une macro en dehors de ta macro pour trier les nouvelles données. Cette macro étant appelée en fin de macro ci-dessus.

Bonjour à tous,

mon essai:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, [Q3:Q250]) Is Nothing Then 'plage à adapter
        If Target.Count > 1 Then Exit Sub         'si on modifie plusieurs cellules simultanément
        If UCase(Target) = "EN VEILLE" Then
            nouvlig = Sheets("EN VEILLE").Cells(Rows.Count, 1).End(xlUp).Row + 1 'index de la première ligne vide dans "Archives"
            Cells(Target.Row, 1).Resize(1, 26).Copy
            With Sheets("EN VEILLE")
                .Cells(nouvlig, 1).Resize(1, 26).PasteSpecial
                With .Cells(1, "A").CurrentRegion
                    .Cells.Sort Key1:=.Range("B1"), Order1:=xlAscending, _
                                Key2:=.Range("A1"), Order2:=xlAscending, _
                                Orientation:=xlTopToBottom, Header:=xlYes
                End With
            End With

            Application.EnableEvents = False      'désactiver les événements
            Cells(Target.Row, 1).EntireRow.Delete
            Application.EnableEvents = True
        End If
        On Error Resume Next
        If Not Intersect(Target, [Q3:Q250]) Is Nothing Then 'plage à adapter
            If Target.Count > 1 Then Exit Sub     'si on modifie plusieurs cellules simultanément
            If UCase(Target) = "PERDU" Then
                nouvlig = Sheets("PERDU").Cells(Rows.Count, 1).End(xlUp).Row + 1 'index de la première ligne vide dans "Archives"
                Cells(Target.Row, 1).Resize(1, 26).Copy
                 With Sheets("PERDU")
                .Cells(nouvlig, 1).Resize(1, 26).PasteSpecial
                With .Cells(1, "A").CurrentRegion
                    .Cells.Sort Key1:=.Range("B1"), Order1:=xlAscending, _
                                Key2:=.Range("A1"), Order2:=xlAscending, _
                                Orientation:=xlTopToBottom, Header:=xlYes
                End With
            End With
                Application.EnableEvents = False  'désactiver les événements
                Cells(Target.Row, 1).EntireRow.Delete
                Application.EnableEvents = True
            End If
        End If
    End If
End Sub

Bonjour Steelson,

Désolé pour ma réponse un peu tardive.

Voici un exemple de fichier

Merci pour votre aide.

Bonjour,

est-ce que la réponse de Sequoyah te convient ?

Sequoyah,

Votre code génère une erreur d'exécution '1004' - La méthode Sort de la classe Range a échoué.

Voici ce qui est pointé du doigt :

                    .Cells.Sort Key1:=.Range("B3"), Order1:=xlAscending, _
                                Key2:=.Range("A3"), Order2:=xlAscending, _
                                Orientation:=xlTopToBottom, Header:=xlYes

Merci également pour votre soutien

juju

Bonjour juju,

ça devrait marcher si on supprime la première ligne vide sur toutes les feuilles et si on change la ligne:

If Not Intersect(Target, [Q3:Q250]) Is Nothing Then 'plage à adapter

avec

If Not Intersect(Target, [Q2:Q250]) Is Nothing Then 'plage à adapter

deux fois dans le code.

Cordialement.

Hello Sequoyah,

j'ai préféré te laisser répondre ...

Bonsoir,

Cela fonctionne dans mon exemple. Malheureusement, dans mon vrai fichier, j'ai besoin de la première ligne vide dans l'onglet "ACTIF". Il y a des boutons liées à des macros sur cette ligne et je n'ai d'autres places pour les mettre.

Pensez-vous qu'il soit possible de modifier le code en conséquence ?

Merci par avance,

Juju

A noter que même en supprimant la première ligne de chaque onglet, j'ai toujours cette erreur

Bonjour juju,

une autre essai, ne change pas ton code original dans la feuille ACTIF et dans le module des feuilles PERDU et EN VEILLE écrit le code suivant (à changer le nom de la feuille):

Private Sub Worksheet_Activate()

    Dim ws     As Worksheet
    Set ws = Worksheets("EN VEILLE")

    With ws
        Dim LastRow     As Integer
        LastRow = Cells(Rows.Count, 1).End(xlUp).Row

        With .Sort

            With .SortFields
                .Clear
                .Add Key:=Range("B3:B" & LastRow), _
                     SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Add Key:=Range("A3:A" & LastRow), _
                     SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With

            .SetRange ws.Range("A2:T" & LastRow)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

End Sub

Bonjour sequoyah,

Alors, le transfert de ACTIF vers EN VEILLE ou PERDU fonctionne et le tri se fait. En revanche, le retour ne se fait plus.

On avance (enfin vous !)

Encore bonjour

dans un module standard:

Sub Sorting()

    Dim ws     As Worksheet
    Set ws = ActiveSheet

    With ws
        Dim LastRow     As Integer
        LastRow = Cells(Rows.Count, 1).End(xlUp).Row

        With .Sort

            With .SortFields
                .Clear
                .Add Key:=Range("B3:B" & LastRow), _
                     SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .Add Key:=Range("A3:A" & LastRow), _
                     SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            End With

            .SetRange ws.Range("A2:T" & LastRow)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With

End Sub

Dans le module de chaque feuille, après la ligne:

Sheets("EN VEILLE").Cells(nouvlig, 1).Resize(1, 26).PasteSpecial

ajoute la ligne:

Call Sorting

Bonjour bonjour,

Alors, le code fonctionne. Plus de bug.

En revanche, lorsque le mouvement d'une feuille à l'autre se fait, la ligne ne se classe pas. Le reste du tableau est classé par ordre comme demandé mais la nouvelle ligne s'insert en bas du tableau, à la suite.

Peut-être que j'ai mal positionné le call ?

Cordialement,

Juju

J'ai un problème que je viens de déceler, la ligne déplacée de l'onglet "En veille" à "Actif" ne se supprime plus. Elle est effectivement copiée-collée dans l'onglet Actif mais reste dans l'onglet En veille également.

Edit : problème corrigé en déplaçant l'appel de la macro sorting en fin de code.

Mais toujours ce problème de classement qui s'effectue sans la ligne ajoutée.

Bonjour,

si tu passes en tableau, la macro devient

Sub TRI(feuille As String)
Dim sw As Object
Set sw = Sheets(feuille)
    With sw.ListObjects(1)
        .Range.Sort Key1:=.ListColumns(1), order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End With
    With sw.ListObjects(1)
        .Range.Sort Key1:=.ListColumns(2), order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End With
End Sub

fais un test

Sub test()
    TRI ("EN VEILLE")
End Sub

Bonjour Steelson,

J'ai corrigé la macro sorting par votre macro tri.

J'ai intégré l'exécution de la macro tri dans le code

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, [Q3:Q250]) Is Nothing Then 'plage à adapter
    If Target.Count > 1 Then Exit Sub 'si on modifie plusieurs cellules simultanément
    If UCase(Target) = "EN VEILLE" Then
        nouvlig = Sheets("EN VEILLE").Cells(Rows.Count, 1).End(xlUp).Row + 1 'index de la première ligne vide dans "Archives"
        Cells(Target.Row, 1).Resize(1, 26).Copy
        Sheets("EN VEILLE").Cells(nouvlig, 1).Resize(1, 26).PasteSpecial
        TRI ("EN VEILLE")
        Application.EnableEvents = False 'désactiver les événements
        Cells(Target.Row, 1).EntireRow.Delete
        Application.EnableEvents = True
    End If
    On Error Resume Next
If Not Intersect(Target, [Q3:Q250]) Is Nothing Then 'plage à adapter
    If Target.Count > 1 Then Exit Sub 'si on modifie plusieurs cellules simultanément
    If UCase(Target) = "PERDU" Then
        nouvlig = Sheets("PERDU").Cells(Rows.Count, 1).End(xlUp).Row + 1 'index de la première ligne vide dans "Archives"
        Cells(Target.Row, 1).Resize(1, 26).Copy
        Sheets("PERDU").Cells(nouvlig, 1).Resize(1, 26).PasteSpecial
        TRI ("PERDU")
        Application.EnableEvents = False 'désactiver les événements
        Cells(Target.Row, 1).EntireRow.Delete
        Application.EnableEvents = True
    End If
End If
End If
End Sub

Et toujours le même problème. Le tri s'effectue mais pas pour la ligne nouvellement intégrée.

Bonjour à tous,

une autre solution, la macro Sorting est lancéee lorsque la feuille est activée, avec le code:

Private Sub Worksheet_Activate()
Call Sorting
End Sub

voir fichier joint

Sequoyah,

Merci cela fonctionne parfaitement ! J'aurais dû y penser

Problème résolu !!

juju_ski a écrit :

Problème résolu !!

Pas tout à fait si tu veux progresser, t'affranchir des lignes vierges, des valeurs de type

If Not Intersect(Target, [Q3:Q250]) Is Nothing Then 'plage à adapter

Adopte une structure tableaux y compris dans ta macro avec ListObjects(1) et ta macro sera beaucoup beaucoup beaucoup plus simple !

Si tu le souhaites, je te le fais demain à titre de démonstration. C'est aussi ce que moi j'ai appris au travers de ce forum.