Tri données Excel avec VBA selon liste

Le 11/02/2023 à 17:09

Bonjour,

Dans un précédent sujet, Jean-Eric m'a codé une macro qui me permet de trier les données de mes feuilles en suivant la liste présente dans la feuille "Table".

Le tri fonctionne très bien (merci à vous Jean-Eric !) Par contre, je n'arrive plus à travailler sur mes feuilles après avoir exécuter ce code.

Par exemple, je voudrais pouvoir sélectionner la cellule A1 de chaque feuille parcourue mais j'ai un message d'erreur: "erreur 1004: La méthode Select de la classe Range a échoué"

Pourriez-vous me venir en aide s'il vous plait ? Je débute en VBA, soyez indulgents s'il vous plait.

Merci beaucoup !

JB

41tri-jb.xlsm (23.60 Ko)
Le 11/02/2023 à 18:15

Bonjour

Ajoute simplement

wsData.Select

avant

Range("A1").Select

A+ François

Le 11/02/2023 à 18:22

Bonjour,

Le Select bloque car la feuille n'est pas active, il faut juste insérer l'activation de la feuille comme ci-dessous.

    Application.DeleteCustomList m
    wsData.Activate    ' Ligne à insérer
    wsData.Range("A1").Select bloque
Le 11/02/2023 à 18:36

Bonjour à tous

Le code de Jean-Eric refait la liste à chaque feuille

On peut simplifier comme cela

Option Explicit

Public Sub TRI_personnalisé()

Dim derniereligne_Table_A As Long, derniereligne_Table_B As Long, derniereligne_Table_C As Long, derniereligne_Table_D As Long, derniereligneA As Long
Dim wsData As Worksheet, wsList As Worksheet
Dim m As Long, ctrl As Boolean, n As Long
Dim rngData As Range, rngList

    On Error GoTo errHandler

    derniereligne_Table_A = Sheets("Table").Range("A" & Rows.Count).End(xlUp).Row
    Set wsList = ActiveWorkbook.Worksheets("Table")
    Set rngList = wsList.Range("A4:A" & derniereligne_Table_A)
    Application.AddCustomList ListArray:=rngList
    m = Application.CustomListCount

    For n = 1 To Sheets.Count

   If Left(Sheets(n).Name, 3) = "DEP" Then

    Set wsData = ActiveWorkbook.Sheets(n)
    derniereligneA = Sheets(n).Range("A" & Rows.Count).End(xlUp).Row
    Set rngData = wsData.Range("A1:D" & derniereligneA)

    With wsData.Sort
        .SortFields.Add _
                Key:=rngData(1), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                CustomOrder:=Application.CustomListCount
        .SortFields.Add _
                Key:=rngData(4), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending
        .SetRange rngData
        .Header = xlNo
        .Apply
        .SortFields.Clear
    End With
bloque
    End If

    Next n

exitHandler:
    Application.DeleteCustomList m
    Exit Sub
errHandler:
    MsgBox "Erreur : " & Err.Number & Chr(10) & Err.Description
    Resume exitHandler

End Sub

Je ne vois pas trop l’intérêt du select dans la boucle de tri...

Le 12/02/2023 à 18:53

Bonjour,
De ce que je comprends !
Cdlt.

23tri-jb.xlsm (26.81 Ko)
Option Explicit

Public Sub TRI_personnalisé()
Dim wb As Workbook
Dim wsData As Worksheet, wsList As Worksheet
Dim lastRow As Long
Dim rngList As Variant
Dim rngData As Range
Dim m As Long, n As Long

    On Error GoTo errHandler

    Set wb = ThisWorkbook
    Set wsList = wb.Worksheets("Table")

    With wsList
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rngList = .Range("A4:A" & lastRow)
    End With

    Application.AddCustomList ListArray:=rngList
    m = Application.CustomListCount

    For n = 1 To wb.Worksheets.Count
        If Left(wb.Worksheets(n).Name, 3) = "DEP" Then
            Set wsData = wb.Worksheets(n)
            With wsData
                lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                Set rngData = .Range("A1:D" & lastRow)
                With .Sort
                    .SortFields.Add _
                            Key:=rngData(1), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending, _
                            CustomOrder:=Application.CustomListCount
                    .SortFields.Add _
                            Key:=rngData(4), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending
                    .SetRange rngData
                    .Header = xlNo
                    .Apply
                    .SortFields.Clear
                End With
            End With
            With wsData
                .Activate
                .Cells(1).Select
            End With
        End If
    Next n

exitHandler:
    With wsList
        .Activate
        .Cells(1).Select
    End With
    Application.DeleteCustomList m
    Exit Sub
errHandler:
    MsgBox "Erreur : " & Err.Number & Chr(10) & Err.Description
    Resume exitHandler

End Sub
Le 13/02/2023 à 15:06

Bonjour à tous,

@78Chris: Je voulais mettre un select en "exemple" car lorsque le tri est terminé, la plage entière était sélectionnée et je ne voulais sélectionner que la cellule A1 après le tri.

@Jean-Eric : Merci pour cette nouvelle proposition, ça fonctionne bien :) Les données des feuilles qui commencent par "DEP" sont triées en fonction de la variable rngList. J'aimerais ajouter une autre condition, c'est à dire : les données des feuilles qui commencent par "VILLE" seront, elles, triées selon la liste en B4:B&rngList2 de la feuille "Table"

With wsList
        lastRow2 = .Cells(.Rows.Count, 2).End(xlUp).Row
        Set rngListB = .Range("B4:B" & lastRow2)
    End With

Où ajouter cela ? Je pensais écrire l'autre condition If... à la suite du code proposé :

Option Explicit

Public Sub TRI_personnalisé()
Dim wb As Workbook
Dim wsData As Worksheet, wsList As Worksheet
Dim lastRow As Long
Dim rngList As Variant
Dim rngData As Range
Dim m As Long, n As Long

    On Error GoTo errHandler

    Set wb = ThisWorkbook
    Set wsList = wb.Worksheets("Table")

    With wsList
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rngList = .Range("A4:A" & lastRow)
    End With

    Application.AddCustomList ListArray:=rngList
    m = Application.CustomListCount

    For n = 1 To wb.Worksheets.Count
        If Left(wb.Worksheets(n).Name, 3) = "DEP" Then
            Set wsData = wb.Worksheets(n)
            With wsData
                lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                Set rngData = .Range("A1:D" & lastRow)
                With .Sort
                    .SortFields.Add _
                            Key:=rngData(1), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending, _
                            CustomOrder:=Application.CustomListCount
                    .SortFields.Add _
                            Key:=rngData(4), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending
                    .SetRange rngData
                    .Header = xlNo
                    .Apply
                    .SortFields.Clear
                End With
            End With
            With wsData
                .Activate
                .Cells(1).Select
            End With
        End If

        If Left(wb.Worksheets(n).Name, 4) = "VILLE" Then
            Set wsData = wb.Worksheets(n)
            With wsData
                lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                Set rngData = .Range("A1:D" & lastRow)
                With .Sort
                    .SortFields.Add _
                            Key:=rngData(1), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending, _
                            CustomOrder:=Application.CustomListCount
                    .SortFields.Add _
                            Key:=rngData(4), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending
                    .SetRange rngData
                    .Header = xlNo
                    .Apply
                    .SortFields.Clear
                End With
            End With
            With wsData
                .Activate
                .Cells(1).Select
            End With
        End If
    Next n

exitHandler:
    With wsList
        .Activate
        .Cells(1).Select
    End With
    Application.DeleteCustomList m
    Exit Sub
errHandler:
    MsgBox "Erreur : " & Err.Number & Chr(10) & Err.Description
    Resume exitHandler

End Sub

Encore un grand merci !!!

JB

Le 13/02/2023 à 15:17

J'ai repris l'exemple de 78chris pour vous présenter ce que je souhaiterais faire. Je pense qu'on peut améliorer car dans le cas présenté ci-dessous, on scrute à 2 reprises toutes les feuilles du classeur (une 1ère fois pour les feuilles qui commencent par DEP, et une seconde fois pour les feuilles qui commencent par VILLE). J'ai 4 conditions à ajouter donc je ne vais pas scruter toutes mes feuilles à 4 reprises

Merci à vous qui prenez le temps de m'aider !! :)

Option Explicit

Public Sub TRI_personnalisé()

Dim derniereligne_Table_A As Long, derniereligne_Table_B As Long, derniereligne_Table_C As Long, derniereligne_Table_D As Long, derniereligneA As Long
Dim wsData As Worksheet, wsList As Worksheet
Dim m As Long, ctrl As Boolean, n As Long
Dim rngData As Range, rngList

    On Error GoTo errHandler

    derniereligne_Table_A = Sheets("Table").Range("A" & Rows.Count).End(xlUp).Row
    Set wsList = ActiveWorkbook.Worksheets("Table")
    Set rngList = wsList.Range("A4:A" & derniereligne_Table_A)
    Application.AddCustomList ListArray:=rngList
    m = Application.CustomListCount

    For n = 1 To Sheets.Count

   If Left(Sheets(n).Name, 3) = "DEP" Then

    Set wsData = ActiveWorkbook.Sheets(n)
    derniereligneA = Sheets(n).Range("A" & Rows.Count).End(xlUp).Row
    Set rngData = wsData.Range("A1:D" & derniereligneA)

    With wsData.Sort
        .SortFields.Add _
                Key:=rngData(1), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                CustomOrder:=Application.CustomListCount
        .SortFields.Add _
                Key:=rngData(4), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending
        .SetRange rngData
        .Header = xlNo
        .Apply
        .SortFields.Clear
    End With

    End If

    Next n

   derniereligne_Table_B = Sheets("Table").Range("B" & Rows.Count).End(xlUp).Row
    Set wsList = ActiveWorkbook.Worksheets("Table")
    Set rngList = wsList.Range("B4:B" & derniereligne_Table_B)
    Application.AddCustomList ListArray:=rngList
    m = Application.CustomListCount

    For n = 1 To Sheets.Count

   If Left(Sheets(n).Name, 4) = "VILLE" Then

    Set wsData = ActiveWorkbook.Sheets(n)
    derniereligneA = Sheets(n).Range("A" & Rows.Count).End(xlUp).Row
    Set rngData = wsData.Range("A1:D" & derniereligneA)

    With wsData.Sort
        .SortFields.Add _
                Key:=rngData(1), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                CustomOrder:=Application.CustomListCount
        .SortFields.Add _
                Key:=rngData(4), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending
        .SetRange rngData
        .Header = xlNo
        .Apply
        .SortFields.Clear
    End With

    End If

    Next n

exitHandler:
    Application.DeleteCustomList m
    Exit Sub
errHandler:
    MsgBox "Erreur : " & Err.Number & Chr(10) & Err.Description
    Resume exitHandler

End Sub

JB

Le 13/02/2023 à 19:10

Bonjour

Tu appliques la même chose aux 4 types de feuilles à part la table de tri ?

Le 13/02/2023 à 21:06

Bonsoir,

Pour les feuilles qui commencent par DEP je veux tirer selon la liste en colonne A de la feuille Table

Pour les feuilles qui commencent par VILLE je veux trier selon la liste en colonne B de la feuille Table

Pour les feuilles qui commencent par COMMUNE je veux trier selon la liste en colonne C de la feuille Table

Pour les feuilles qui commencent par REGION je veux trier selon la liste en colonne D de la feuille Table

Les listes peuvent évoluer en nombre de lignes mais resteront en colonnes A,B,C et D

Le but est de procéder comme pour le 1er code mais pour les autres conditions If...

Merci beaucoup piur votre aide :)

JB

Le 14/02/2023 à 08:37

Bonjour

33tri-jb3.xlsm (34.72 Ko)
Le 17/02/2023 à 20:28

Bonjour 78chris,

Merci beaucoup pour votre retour mais j'ai un msgbox d'erreur en exécutant le tri, est-ce le cas aussi de votre côté ?

image

Bonne soirée !

JB

Le 17/02/2023 à 22:04

Bonjour

Non sur le fichier posté je n'ai pas d'erreur, ni sur 365, ni sur 2010

Le 18/02/2023 à 10:06

Bonjour 78Chris, JeanBaptisteP

Le conseil de microsoft sur AddCustomList et l'erreur 1004

If the list that you are trying to add already exists, this method throws a run-time error 1004. Catch the error with an On Error statement.

https://learn.microsoft.com/en-us/office/vba/api/excel.application.addcustomlist

Le 18/02/2023 à 18:02

Bonjour

@scraper : j'avais pensé à cette hypothèse. Si on part d'un Excel "propre" il n'y a pas de souci mais effectivement s'il y a eu plusieurs essais qui ne sont pas allés jusqu'à la suppression de la liste et donc des liste résiduelles, il est bien de le prévoir

A noter que le resume next permet d'éviter l'erreur mais pas de nettoyer la liste des listes...

Le 18/02/2023 à 20:08

Bonsoir le forum,

Une autre façon de réorganiser tes données.

Je me suis appuyé sur le fichier fourni par 78chris.

Les clés du dictionnaire parent renvoient le nom des feuilles

Les clés du dictionnaire enfant renvoient les noms formant chaque liste de la feuille "Table"

L'item associé à chaque clé du dictionnaire enfant renvoie un tableau à 2 dimensions

Option Explicit
Sub test()
Dim a, b, w, e, s, dico As Object, ws As Worksheet
Dim i As Long, ii As Byte, col As Byte, n As Long
Set dico = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
a = Sheets("Table").Range("A4").CurrentRegion.Value
For Each ws In Worksheets
    If ws.Name <> "Table" Then
        With ws.Range("a1").CurrentRegion.Resize(, 4)
            .Sort key1:=.Cells(1, 4), order1:=xlAscending, Header:=xlNo
        End With
        Set dico(ws.Name) = CreateObject("Scripting.Dictionary")
        dico(ws.Name).CompareMode = 1
        Select Case True
            Case ws.Name Like "DEP*"
                col = 1
            Case ws.Name Like "VILLE*"
                col = 2
            Case ws.Name Like "COMMUNE*"
                col = 3
            Case ws.Name Like "REGION*"
                col = 4
        End Select
        a = Sheets("Table").Range("A4").CurrentRegion.Columns(col).Value
        For i = 1 To UBound(a, 1)
            If Not IsEmpty(a(i, 1)) Then
                dico(ws.Name)(a(i, 1)) = Empty
            End If
        Next
        b = ws.Range("A1").CurrentRegion.Resize(, 4).Value
        For i = 1 To UBound(b, 1)
            If dico(ws.Name).exists(b(i, 1)) Then
                If IsEmpty(dico(ws.Name)(b(i, 1))) Then
                    ReDim w(1 To 4, 1 To 1)
                Else
                    w = dico(ws.Name)(b(i, 1))
                    ReDim Preserve w(1 To 4, 1 To UBound(w, 2) + 1)
                End If
            End If
            For ii = 1 To UBound(b, 2)
                w(ii, UBound(w, 2)) = b(i, ii)
            Next
            dico(ws.Name)(b(i, 1)) = w
        Next
        n = 1
        'restitution à partir de la colonne F
        For Each e In dico
            For Each s In dico(e)
                If Not IsEmpty(dico(e)(s)) Then
                    ws.Cells(n, 6).Resize(UBound(dico(e)(s), 2), UBound(dico(e)(s), 1)) = _
                    Application.Transpose(dico(e)(s))
                    n = n + UBound(dico(e)(s), 2)
                End If
            Next
        Next
        dico.RemoveAll
    End If
Next
Set dico = Nothing
Application.ScreenUpdating = True
End Sub

klin89

Le 18/02/2023 à 20:25

Re,

Le code réajusté au niveau de la dernière boucle :

Option Explicit
Sub test()
Dim a, b, w, e, dico As Object, ws As Worksheet
Dim i As Long, ii As Byte, col As Byte, n As Long
Set dico = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
a = Sheets("Table").Range("A4").CurrentRegion.Value
For Each ws In Worksheets
    If ws.Name <> "Table" Then
        With ws.Range("a1").CurrentRegion.Resize(, 4)
            .Sort key1:=.Cells(1, 4), order1:=xlAscending, Header:=xlNo
        End With
        Set dico(ws.Name) = CreateObject("Scripting.Dictionary")
        dico(ws.Name).CompareMode = 1
        Select Case True
            Case ws.Name Like "DEP*"
                col = 1
            Case ws.Name Like "VILLE*"
                col = 2
            Case ws.Name Like "COMMUNE*"
                col = 3
            Case ws.Name Like "REGION*"
                col = 4
        End Select
        a = Sheets("Table").Range("A4").CurrentRegion.Columns(col).Value
        For i = 1 To UBound(a, 1)
            If Not IsEmpty(a(i, 1)) Then
                dico(ws.Name)(a(i, 1)) = Empty
            End If
        Next
        b = ws.Range("A1").CurrentRegion.Resize(, 4).Value
        For i = 1 To UBound(b, 1)
            If dico(ws.Name).exists(b(i, 1)) Then
                If IsEmpty(dico(ws.Name)(b(i, 1))) Then
                    ReDim w(1 To 4, 1 To 1)
                Else
                    w = dico(ws.Name)(b(i, 1))
                    ReDim Preserve w(1 To 4, 1 To UBound(w, 2) + 1)
                End If
            End If
            For ii = 1 To UBound(b, 2)
                w(ii, UBound(w, 2)) = b(i, ii)
            Next
            dico(ws.Name)(b(i, 1)) = w
        Next
        n = 1
        'restitution à partir de la colonne F
        For Each e In dico(ws.Name)
            If Not IsEmpty(dico(ws.Name)(e)) Then
                ws.Cells(n, 6).Resize(UBound(dico(ws.Name)(e), 2), UBound(dico(ws.Name)(e), 1)) = _
                Application.Transpose(dico(ws.Name)(e))
                n = n + UBound(dico(ws.Name)(e), 2)
            End If
        Next
        dico.RemoveAll
    End If
Next
Set dico = Nothing
Application.ScreenUpdating = True
End Sub

klin89

Le 25/02/2023 à 18:29

Bonjour à tous,

Merci beaucoup je vais essayer toutes vos propositions :)

Bonne soirée à vous et encore un grand merci !

JB

Le 26/02/2023 à 08:42

Bonjour,
Une nouvelle proposition.
Bon weekend.
Cdlt.

16tri-jb4.xlsm (33.71 Ko)
Option Explicit

'Tris personnalisés
Public Sub CustomSorts()
Dim ws As Worksheet, rngData As Range, n As Long

    On Error GoTo errHandler
    Application.ScreenUpdating = False
    'DeleteCustomLists
    CreateCustomLists
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Table" Then
            Select Case Left(ws.Name, 3)
                Case "DEP": n = 5
                Case "VIL": n = 6
                Case "COM": n = 7
                Case "REG": n = 8
                Case Else:
            End Select
            Set rngData = ws.Range("A1:D" & ws.Range("A" & Rows.Count).End(xlUp).Row)
            With ws
                With .Sort
                    .SortFields.Add _
                            Key:=rngData(1), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending, _
                            CustomOrder:=n
                    .SortFields.Add _
                            Key:=rngData(4), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending
                    .SetRange rngData
                    .Header = xlNo
                    .Apply
                    .SortFields.Clear
                End With
                .Activate
                .Cells(1).Select
            End With
        End If
    Next ws

exitHandler:
    DeleteCustomLists
    With Worksheets("Table")
        .Activate
        .Cells(1).Select
    End With
    Exit Sub
errHandler:
    MsgBox "Erreur : " & Err.Number & Chr(10) & Err.Description
    Resume exitHandler
End Sub

'Supprimer les listes personnalisées
Private Sub DeleteCustomLists()
Dim n As Long
    For n = Application.CustomListCount To 5 Step -1
        Application.DeleteCustomList (n)
    Next n
End Sub

'Creer les listes personnalisées
Private Sub CreateCustomLists()
Dim lCol As Long, lRow As Long, rngList As Range
    For lCol = 1 To 4
        With ActiveWorkbook.Worksheets("Table")
            lRow = .Cells(.Rows.Count, lCol).End(xlUp).Row
            Set rngList = .Cells(4, lCol).Resize(lRow - 3)
            Application.AddCustomList rngList
        End With
    Next lCol
End Sub
Le 03/03/2023 à 14:42

Bonjour Jean-Eric,

Je tiens à vous remercier pour votre proposition car avec ce nouveau code je n'ai plus de message d'erreur avec mon EXCEL 2016 !

Je vais faire le test avec un fichier similaire pour voir si tout est trié correctement mais il n'y a pas de raison!

Je reviendrai ici pour clôturer le sujet si tout est ok de mon côté :)

Bonne journée

JB

Rechercher des sujets similaires à "tri donnees vba liste"