Trie à partir d'une liste personnalisée sur une autre feuill

Bonjour à tous,

Je dois crée une liste de pièces à partir de blocs d'un dessin Autocad, je suis en train d'automatiser le processus de création de document mais je suis actuellement bloqué et je ne trouve pas de solution dans les sujets existants.

Voici ma difficulté: je cherche à trié une liste de caractères en fonction d'une liste inscrite sur une autre feuille, le tout en une macro, je m'explique:

Dans la feuille à trier "Feuil1" j'ai différents caractères commençant en "B5" jusqu'à la première cellule vide: MC EL, MC LCV, MC PM,..... et dans ma feuille de référence pour le trie "Supp Trie" j'ai organisé les caractères que je souhaiterais dans un ordre particulier de "C2" jusqu'à la première cellule vide: PM, LCV, LSH,.....

L'ordre des caractères de la feuille "Supp Trie" doivent pouvoir être modifier et influencer la "Feuil1".

De plus le trie ne devra pas tenir compte d'un caractère unique a chaque fichier qui sera modifié par ces caractères, et par sa position dans l'ensemble des cellule à trier, ici MC. J'ai déja reçu de l'aide sur ce forum pour la suppression de ligne en fonction de caractères d'une autre feuille, et cela à créer une cellule nommé "dele" en "J1" avec le caractère unique pour ne pas en tenir compte lors de la suppression.

Je vous envoie une copie du fichier sur lequel je travail.

Je vous remercie par avance des réponses que vous pourrez m'apporter.

Pour activé la macro cliquez sur l'emoticone, est allez cherchez le 2eme fichier texte

Bonjour,

assez curieusement j'ai vu ce ficher il y a max 2 semaines; pourquoi ne pas avoir continué sur le même #post ?

et je me suis déjà demandé pourquoi tes lignes vides entre chaque blocs ?

Pas sur d'avoir compris mais un tri peut se faire comme ceci

P.

J'ai changé de sujet donc changement de #post.

Et les lignes vides s’insèrent la fin de la macro pour une meilleur visibilité entre les équipements.

Je viens d'ouvrir le fichier que tu m'a envoyé patrick1957 mais sa ne va pas, désolé. Il n'y à pas un moyen pour faire une macro qui va chercher l'ordre de position des caractères sur ma feuille "Supp Trie" pour classer ma Feuil1 dans le même ordre en sachant que le caractère unique ici MC ne doit pas être pris en compte lors du trie?

Dans le fichier, la colonne A (tri) mets un chiffre qui corresponds à l'ordre de la colonne C de l'onglet "supp trie" , donc c'est trié comme dans ton code à la ligne

SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _ "PM,VA,LSL,LSH,FL,PSL,DP,PH,QT,AU,PL,PH,LL,LH,DF,EL,SL,LT,OT,FT,DT,CT,TT,PT,HT,EA,ST,VT,YT,IT,LCV,TV,PV,LV,HV,VF,SA,TCV,PCV,VAR,BC,CH,AT,FM,FO,PG,LV,VE,BA,CF,DE,SU,BL,BR,PO,RC,HO,CL,PU,PA,PE,VE,TM,MD,VI,EV,MA,VP,SE,RE,PV,AE,CP,FI,JR,FA,ET,CO,EP,GA,CS,VM,CA,FL,EC,FI,CR,SP,LY,PI,TI",

"PM" est bien 1 , "Va" en 2 et "EL" en 15 ...

Je ne sais pas ce que tu veux et je vais devoir quitter le pc, j'espère que d'autres viendront à ton aide

P.

Désolé si je ne suis pas suffisamment clair

Je voudrai une macro qui effectue un trie de la colonne B Feuil1 à partir de la ligne 5, d'après une liste sur la colonne C à partir de la ligne 2 de la feuille "Supp Trie". Cette macro remplacera la portion de macro existante concernant le trie.

Je veux qu'en modifiant l'ordre de la liste de la feuille "Supp Trie" la position des caractères de la Feuil1 se modifie également lorsque je lance la macro. Difficulté supplémentaire il y à un caractère unique commun à chaque cellule de la colonne B ici MC qui ne doit pas être pris en compte lors du trie, et qui pourra se trouver avant ou après le caractère utile à trier.

La macro sera lancée régulièrement pour mettre à jour les informations.

La modification que tu as apporté ne fonctionne pas lorsque je lance ma macro.

Je ne sais pas si mon explication va aidez, mais je vous remercie de l'aide que vous pourrez m'apporter.

Bonsoir Kirua27, patrick1957, le forum

Au préalable, il faut revoir ta liste en la préfixant du terme choisi ---> MC

Puis te placer sur la feuille à trier

Sub tri()
Dim r As Range
    Application.ScreenUpdating = False
    'cellule où commence ta liste personnalisée
    Set r = Sheets("Supp Trie").Range("d2")
    If Not r Is Nothing Then
        'Ajoute la liste personnalisée
        Application.AddCustomList Range(r, r.End(xlDown))
        'Tri la plage concernée sur la feuille placée en 1ère position ds ton classeur
        Sheets(1).Range("a3:h66").Sort _
                Key1:=Range("b4"), _
                Header:=xlYes, OrderCustom:=Application.CustomListCount + 1
        'supprime la liste personnalisée
        Application.DeleteCustomList Application.CustomListCount
    End If
    Set r = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour klin89 et patrick1597

J'ai fais les modifications nécessaires mais il y à un souci sur le code que tu m'a envoyé klin89 sur la ligne:

Application.AddCustomList Range(r, r.End(xlDown))

Je ne sais pas exactement ce qui ne vas pas

Cette ligne défini une plage pour une liste perso entre "r" qui est la cellule "C2" de la feuille "Supp Trie" ET la dernière cellule remplie de la colonne C

Kirua27 a écrit :

Cette ligne défini une plage pour une liste perso entre "r" qui est la cellule "C2" de la feuille "Supp Trie" ET la dernière cellule remplie de la colonne C

Oui c'est bien ça

Ok par contre avec les modifications que j'ai apporté je ne peux pas faire de liste personnalisé, car les cellules ont toutes des formules dans la liste prévu pour servir d'ordre de trie.

Est-ce qu'il y a un moyen de faire une liste perso avec des cellules contenant des formules?

re Kirua27,

A partir de D2, j'avais placé cette formule à recopier vers le bas

="MC "&C2

La modification :

Sub tri()
Dim r As Range
    Application.ScreenUpdating = False
    'cellule où commence ta liste personnalisée
   Set r = Sheets("Supp Trie").Range("d2")
    If Not r Is Nothing Then
        'Ajoute la liste personnalisée
       Application.AddCustomList Range(r, r.End(xlDown)).Value
        'Tri la plage concernée sur la feuille placée en 1ère position ds ton classeur
       Sheets(1).Range("a3:h66").Sort _
                Key1:=Range("b4"), _
                Header:=xlYes, OrderCustom:=Application.CustomListCount + 1
        'supprime la liste personnalisée
       Application.DeleteCustomList Application.CustomListCount
    End If
    Set r = Nothing
    Application.ScreenUpdating = True
End Sub

Exécuter la macro à partir de la feuille à trier, ici elle est en position 1dans ton classeur

klin89

Désolé mais cela ne fonctionne toujours pas j'ai intégrer ta macro à la mienne elle s’exécute mais le trie ne se fais pas dans l’ordre de ma liste, c'est classer par ordre alphabétique.

J'ai tenté de faire une liste perso en manuel mais je suis limité à 255 caractères et ma liste en compte plus de 360, est-ce que c'est cela qui pourrais posé problème?

Bonjour

Je ne trouve pas de solution à mon problème je vais essayer de faire autrement, si vous pouvez m'aider.

Si je définit la colonne "B" , entre "B5" et la première cellule vide, et que je supprime les caractères identique à celui de la cellule J1 nommée "dele" (cette cellule contient le caractère à supprimé "MC").

Puis j’effectue mon trie selon l'ordre définit sur la feuille "Supp Trie".

Enfin je ré-intègre le caractère de la cellule "dele", à gauche ou à droite du caractère existant dans la cellule (avec un espace) de la colonne "B" entre "B5" et la première cellule vide, en fonction du projet.

Re

J'ai enfin réussi ce que je voulais, mais un autre problème à surgit: Excel plante lorsque j'enregistre je pence que cela viens de ma dernière macro.

Celle-ci s’exécute correctement mais impossible d'enregistrer après, j'ai besoin de votre aide svp.

  'Supprime la valeur de la cellule en J1 en jaune de la colonne B
Dim Cel As Range, Plage As Range
Dim Mot As String
    Set Plage = Range("B5:B150") ' à adapter à la plage à parcourir.
    Mot = Range("dele").Value 'adapter au mot à rechercher et à supprimer
    'Pas nécessaire si le plage est petite
    Application.ScreenUpdating = False
    For Each Cel In Plage
        If Cel Like "*" & Mot & "*" Then
            Cel = Replace(Cel, Mot, "")
            'Pour enlever le double espace qui en résulte..
            Cel = Replace(Cel, " ", "")
        End If
    Next Cel
    Application.ScreenUpdating = True

'Création d'une liste perso et trie selon cette dernière puis trie croissant
Application.AddCustomList ListArray:=Sheets("supp trie").Range("G2:G100")
          Sheets("Feuil1").Range("B5:H250").Sort _
                    Key1:=Range("B5"), _
                    Header:=xlYes, OrderCustom:=Application.CustomListCount + 1
'trie croissant
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C5:C250") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("B5:H250")
        .Header = xlGuess
        .MatchCase = True
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'supprime liste perso
Application.DeleteCustomList Application.CustomListCount
            Set r = Nothing
Application.ScreenUpdating = True

'inserer le caractere d'une cellule nommée, dans une plage de cellule a gauche ou à droite à definir
Dim L As Long, L1 As Long, L2 As Long
Dim P As String
Const numCol = 2
 P = Sheets("Feuil1").Range("dele").Value
With Application.ThisWorkbook.Sheets("Feuil1")
    L2 = .Cells(65536, numCol).End(xlUp).Row
    L1 = .Cells(L2, numCol).End(xlUp).Row
     For L = L1 To L2
'Ajouter une ' devant .Cells que vous n'utilisez pas et supprimé (si il y a) ' devant .Cells que vous utilisez.
    'Pour les projet dont le tag client est ( MC.VA.101)
        .Cells(L, numCol) = "MC " & .Cells(L, numCol)
    'Pour les projet dont le tag client est (VA.MC.101)
       ' .Cells(L, numCol) = Cells(L, numCol) & "P"
    Next L
End With

C'est bon j'ai trouvé il me manquer juste un +1

Application.AddCustomList ListArray:=Sheets("supp trie").Range("G2:G100")
          Sheets("Feuil1").Range("B5:H250").Sort _
                    Key1:=Range("B5"), _
                    Header:=xlYes, OrderCustom:=Application.CustomListCount + 1
'trie croissant
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C5:C250") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("B5:H250")
        .Header = xlGuess
        .MatchCase = True
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'supprime liste perso
Application.DeleteCustomList Application.CustomListCount + 1
            Set r = Nothing
Application.ScreenUpdating = True

Maintenant je souhaiterais améliorer ce morceau de code:

Dim L As Long, L1 As Long, L2 As Long
Dim P As String
Const numCol = 2
P = Sheets("Feuil1").Range("dele").Value
With Application.ThisWorkbook.Sheets("Feuil1")
    L2 = .Cells(65536, numCol).End(xlUp).Row
    L1 = .Cells(L2, numCol).End(xlUp).Row
     For L = L1 To L2
'Ajouter une ' devant .Cells que vous n'utilisez pas et supprimé (si il y a) ' devant .Cells que vous utilisez.
    'Pour les projet dont le tag client est ( MC.VA.101)
        .Cells(L, numCol) = "P " & .Cells(L, numCol)
    'Pour les projet dont le tag client est (VA.MC.101)
       ' .Cells(L, numCol) = Cells(L, numCol) & "P"
    Next L
End With

parce que je souhaite qu'il aille chercher la valeur de la cellule pour ne pas avoir à rentrer dans la macro pour modifier le MC. ici j'ai demander à P d'aller chercher cette valeur mais sa ne fonctionne pas il m'inscrit P à la place de la valeur demander. Avez-vous des idées?

re Kirua27,

J'en suis resté au pseudo-tri

Tu souhaites toujours réorganiser tes données de la Feuil1 en fonction de l'ordre des clés figurant en feuille "Supp Trie" colonne C

Feuille "Supp Trie", à partir de D2, place cette formule

="MC "&C2

Puis exécute cette macro :

Restitution en Feuil2 préalablement créée

Option Explicit
Sub test()
Dim a(), b(), w(), i As Long, j As Long, n As Long
Dim dico As Object, e, x
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Supp Trie")
        b = .Range("d2", .Range("d" & .Rows.Count).End(xlUp)).Value
    End With
    For i = 1 To UBound(b, 1)
        If Not dico.exists(b(i, 1)) Then
            dico(b(i, 1)) = Empty
        End If
    Next i
    a = Sheets("Feuil1").Range("b3:h66").Value
    For i = 2 To UBound(a, 1)
        If dico.exists(a(i, 1)) Then
            If IsEmpty(dico(a(i, 1))) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = dico(a(i, 1))
                ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
            End If
            For j = 1 To UBound(a, 2)
                w(j, UBound(w, 2)) = a(i, j)
            Next
        Else
            ReDim w(1 To UBound(a, 2), 1 To 1)
            For j = 1 To UBound(a, 2)
                w(j, 1) = a(i, j)
            Next
        End If
        dico(a(i, 1)) = w
    Next
    For Each e In dico.keys
        If IsEmpty(dico(e)) Then dico.Remove e
    Next
    x = dico.items
    'Restitution en Feuil2
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1)
        .CurrentRegion.Clear
        .Resize(, UBound(a, 2)).Value = a
        With .Offset(1)
            For i = 0 To UBound(x)
                .Offset(n).Resize(UBound(x(i), 2), UBound(x(i), 1)).Value = _
                Application.Transpose(x(i))
                n = n + UBound(x(i), 2)
            Next
        End With
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 19
                .BorderAround Weight:=xlThin
                .HorizontalAlignment = xlCenter
            End With
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

Est-ce bien normal de retrouver en doublons les clés suivantes en colonne C : VE, PV, PH, LV, FL et FI

Par contre, on retrouve LSH en Feuil1 colonne B, clé qui ne figure pas dans ta liste feuille "Supp Trie"

klin89

re Klin89

Merci d'avoir passé du temps pour m'aider, mais je ne comprend rien au code que tu m'a envoyé , j'ai commencé à m’intéresser à VBA il n'y à que quelque semaines, et il faut que je sache explique le fonctionnement de la macro, et là cela va être très compliqué....

Pour les doublons, et le caractère manquant, c'est une erreur de ma part merci de l'avoir relevé

Je suis toujours au trie j'ai juste un problème, dans cette macro:

Sub création_liste_perso()

'Création d'une liste perso et trie selon cette dernière puis trie croissant
Application.AddCustomList ListArray:=Sheets("supp trie").Range("G2:G100")
          Sheets("Feuil1").Range("B5:H250").Sort _
                    Key1:=Range("B5"), _
                    Header:=xlYes, OrderCustom:=Application.CustomListCount + 1
'trie croissant
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C5:C250") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("B5:H250")
        .Header = xlGuess
        .MatchCase = True
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'supprime liste perso
Application.DeleteCustomList Application.CustomListCount 'supprime la liste perso
           Set r = Nothing
Application.ScreenUpdating = True
End Sub

Elle fonctionne mais lorsque j'enregistre Excel plante, j'ai cherché un peu en exécutant la macro étape par étape et c'est lors de la suppression de la liste perso que cela bug. J'ai essayé de mettre les lignes responsable de la suppression en commentaire, et de supprimer la liste en manuel, puis d'enregistré mais Excel plante également.

En rouvrant le fichier une fenêtre apparait: Excel a pu ouvrir le fichier en supprimant ou en réparant le contenu illisible.

Enregistrements supprimés: Tri dans la partie /xl/worksheets/sheet1.xml

Je ne sais pas à quoi cela correspond, pouvez-vous m'aidez de nouveau svp

J'ai reussi à ce qu'il ne crash pas à l'enregistrement en créant la liste sans la supprimer puis en déplaçant la suppression avant la création:

Application.DeleteCustomList Application.CustomListCount
            Set r = Nothing
Application.ScreenUpdating = True

Application.AddCustomList ListArray:=Sheets("supp trie").Range("G2:G100")
          Sheets("Feuil1").Range("B5:H250").Sort _
                    Key1:=Range("B5"), _
                    Header:=xlYes, OrderCustom:=Application.CustomListCount + 1
'trie croissant
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("C5:C250") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("B5:H250")
        .Header = xlGuess
        .MatchCase = True
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Je ne sais toujours pas pourquoi sa marche dans ce sens si vous avez des explications?

J'ai vu que j'avais encore des liaisons dans la macro qui ne fonctionnent pas, dans ce morceau de code:

'inserer le caractere d'une cellule nommée, dans une plage de cellule a gauche ou à droite à definir
Dim L As Long, L1 As Long, L2 As Long
Dim TAG As String
Const numCol = 2
TAG = Sheets("Feuil1").Range("J1").Value
With Application.ThisWorkbook.Sheets("Feuil1")
    L2 = .Cells(65536, numCol).End(xlUp).Row
    L1 = .Cells(L2, numCol).End(xlUp).Row
     For L = L1 To L2
'Ajouter une ' devant .Cells que vous n'utilisez pas et supprimé (si il y a) ' devant .Cells que vous utilisez.
    'Pour les projet dont le tag client est ( MC.VA.101)
        .Cells(L, numCol) ="TAG " & .Cells(L, numCol)
    'Pour les projet dont le tag client est (VA.MC.101)
       ' .Cells(L, numCol) = Cells(L, numCol) & " TAG"
    Next L
End With

Ce morceau de code ne fait pas la liaison entre "TAG=" et son utilisation dans la formule qui suit.

C'est surement quelque chose de simple mais sa me bloque , pouvez-vous me dire ce qui cloche dans ce code?