XL 2010 classer clé dico dans un ordre prédéfini

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
cathodique

cathodique

XLDnaute Barbatruc
Bonjour,

Je voudrais classer les clés d'un dictionnaire dans ordre prédéfini. Un tri dans les 2 sens (croisant/décroissant) ne répondent à mes attentes.
VB: 
Option Explicit
Sub Classer()
Dim tb, i As Long, d As Object
Set d = CreateObject("scripting.dictionary")
tb = [Table].Value

For i = 1 To UBound(tb)
d(tb(i, 3)) = ""
Next i
End Sub
En fait, je voudrais faire 2 choses:
1 - ma bd ne cesse de s'allonger, du coup l'ordre des clés change. les clés en questions sont des abréviations. Actuellement, une abréviation est absente de ma bd, mais il faut la prendre en compte.
Après avoir, compléter le dictionnaire par code, je voudrais classer les clés suivant cet ordre: Cd, Fa, Ad, Ch, Rt (abréviation non présente actuellement.

2 - Dans un deuxième temps, remplacer ces abréviations par leur signification pour éditer un rapport
Cd=Entrée - Fa= famille - Ad=Sortie - Ch=Changement - Rt= Retour

En vous remerciant
 

Pièces jointes

Trier par date Trier par votes
Bonsoir à tous, 🙂

J'ai cru que tu voulais remplacer les clés initiales par leur correspondance, voir le post#1
VB: 
Sub Remplace_cle()
    Dim e, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = 1
    'alimente le dictionnaire avec les cles dans un ordre predefini
    For Each e In Array("Cd", "Fa", "Ad", "Ch", "Rt")
        d(e) = Empty
    Next
    'remplace les cles par leur correspondance
    For Each e In Array(Array("Cd", "Entrée"), _
                        Array("Fa", "Famille"), _
                        Array("Ad", "Sortie"), _
                        Array("Ch", "Changement"), _
                        Array("Rt", "Retour"))
        If d.exists(e(0)) Then d.Key(e(0)) = e(1)
    Next
End Sub
klin89
 
Dernière édition:
Vote positif 0 Vote négatif
klin89 à dit:
Bonsoir à tous, 🙂

J'ai cru que tu voulais remplacer les clés initiales par leur correspondance, voir le post#1
VB: 
Sub Remplace_cle()
    Dim e, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = 1
    'alimente le dictionnaire avec les cles dans un ordre predefini
    For Each e In Array("Cd", "Fa", "Ad", "Ch", "Rt")
        d(e) = Empty
    Next
    'remplace les cles par leur correspondance
    For Each e In Array(Array("Cd", "Entrée"), _
                        Array("Fa", "Famille"), _
                        Array("Ad", "Sortie"), _
                        Array("Ch", "Changement"), _
                        Array("Rt", "Retour"))
        If d.exists(e(0)) Then d.Key(e(0)) = e(1)
    Next
End Sub
klin89
Cliquez pour agrandir...
Bonjour @klin89 😉,

Au post#1, il y a 2 points Classer ensuite remplacer.
Comme ma bd, s'allonge alors en peuplant mon dico, les abréviations ne plus le même ordre.
Je veux donc les cles de mon dico toujours dans le même ordre avant d'exécuter un code.
Ensuite ce dico, me servira d’en-tête d'une présentation, c'est à ce niveau qu'on remplace les abréviations par leur signification.
Merci beaucoup.
Bonne journée.
 
Vote positif 0 Vote négatif
patricktoulon à dit:
re
bonjour
en voilà tout un toin toin pour si peu 😉
VB: 
Option Explicit

Sub Classer()
    Dim tb, d As Object, k, x, message$
    Set d = CreateObject("scripting.dictionary")
    tb = [Table].Value
    'Cd, Fa, Ad, Ch, Rt
    d.Add "Cd", "Entrée"
    d.Add "Fa", "Famille"
    d.Add "Ad", "Sortie"
    d.Add "Ch", "Changement"
    d.Add "Rt", "Retour"

    For Each k In d.keys
        'x = Application.IfError(Application.Match(k, [Table].Columns(3), 0), 0)'methode 1
        x = Evaluate("COUNTIF(" & [Table].Columns(3).Address & ",""" & k & """)")'methode 2
        If x = 0 Then
            d.Remove (k)
        Else
            message = message & k & " : " & d(k) & vbCrLf
        End If
    Next
   
    message = "Dictionnaire d'abréviations :" & vbCrLf & message
    MsgBox message

End Sub
Cliquez pour agrandir...
Bonjour @patricktoulon 😉 ,

Je me rends compte que j'ai de plus en plus de difficulté à rassembler mes connaissances pour résoudre mes problèmes. Je suis pratiquement tout le temps entrain de réinventer la roue.
Oui, tout un remue-ménage pour présenter un papier correct.

Merci beaucoup.

ps: je testerai vos codes un peu plus tard. Je ne suis pas parfaitement réveillé🥱.
 
Vote positif 0 Vote négatif
Rebonjour,

Je n'ai pas pu m'empêcher de test vos codes.
Ils fonctionnent très bien.
J'ai encore 2 cas similaires, je dois donc créer autant de procédures.
Comment transformer vos procédures en fonction à laquelle on passera en argument le dictionnaire et les significations.

En vous remerciant.

Bonne journée.
 
Vote positif 0 Vote négatif
Bonjour à tous,

Je ne comprends pas qu'il faille un Dictionary et 19 messages pour un problème aussi simple :
VB: 
Sub Classer()
Dim c As Range
Application.ScreenUpdating = False
For Each c In [Tableau2[Ordre]]
    [Table[Cat.]].Replace c(1, 2), c & c(1, 2), xlWhole
Next
[Table].Sort Columns(3), xlAscending, Header:=xlYes
For Each c In [Tableau2[Ordre]]
    [Table[Cat.]].Replace c, "", xlPart
Next
End Sub

Sub Remplacer()
Dim c As Range
Application.ScreenUpdating = False
For Each c In [Tableau2[Remplacer]]
    [Table[Cat.]].Replace c, c(1, 2), xlWhole
Next
End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
job75 à dit:
Bonjour à tous,

Je ne comprends pas qu'il faille un Dictionary et 19 messages pour un problème aussi simple :
VB: 
Sub Classer()
Dim c As Range
Application.ScreenUpdating = False
For Each c In [Tableau2[Ordre]]
    [Table[Cat.]].Replace c(1, 2), c & c(1, 2), xlWhole
Next
[Table].Sort Columns(3), xlAscending, Header:=xlYes
For Each c In [Tableau2[Ordre]]
    [Table[Cat.]].Replace c, "", xlPart
Next
End Sub

Sub Remplacer()
Dim c As Range
Application.ScreenUpdating = False
For Each c In [Tableau2[Remplacer]]
    [Table[Cat.]].Replace c, c(1, 2), xlWhole
Next
End Sub
A+
Cliquez pour agrandir...
Bonjour @job75 ,

Merci beaucoup. Je ne veux rien modifier à mon tableau initial.
 
Vote positif 0 Vote négatif
Bonjour cathodique,
cathodique à dit:
Merci beaucoup. Je ne veux rien modifier à mon tableau initial.
Cliquez pour agrandir...
Eh bien il suffit de mettre le résultat dans une autre feuille, la feuille "Classer" :
VB: 
Private Sub Worksheet_Activate()
Dim MaTable As Range, c As Range
Application.ScreenUpdating = False
Cells.Delete 'RAZ
[Table].ListObject.Range.Copy [A1]
Set MaTable = UsedRange
For Each c In [Tableau2[Ordre]]
    MaTable.Columns(3).Replace c(1, 2), c & c(1, 2), xlWhole
Next
MaTable.Sort Columns(3), IIf(Feuil1.[H1] = "Décroissant", xlDescending, xlAscending), Header:=xlYes
For Each c In [Tableau2[Ordre]]
    MaTable.Columns(3).Replace c, "", xlPart
Next
'---remplacer---
For Each c In [Tableau2[Remplacer]]
    MaTable.Columns(3).Replace c, c(1, 2), xlWhole
Next
MaTable.Columns.AutoFit 'ajustement largeurs
End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
Bonsoir cathodique,

Tu m'as répondu par MP :
Je te remercie mais je ne veux ni toucher à mon tableau, ni ajouter de feuille intermédiaire.
Mon but est de constituer une liste des catégories, pour en faire l'entête d'un document à imprimer.
Cliquez pour agrandir...
Alors peut-être en créant un fichier PDF des catégories :
VB: 
Sub PDF()
Dim F As Worksheet, c As Range
Application.ScreenUpdating = False
Set F = Feuil1 'CodeName, à adapter
With Workbooks.Add.Sheets(1) 'document auxiliaire
    F.Range("Table").ListObject.Range.Columns(3).Copy .Cells(1)
    For Each c In F.Range("Tableau2").Columns(1).Cells
        .UsedRange.Replace c(1, 2), c & c(1, 2), xlWhole
    Next
    .UsedRange.Sort Cells(1), xlAscending, Header:=xlYes
    For Each c In F.Range("Tableau2").Columns(1).Cells
        .UsedRange.Replace c, "", xlPart
    Next
    .UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes 'supprime les doublons
    '---remplacer---
    For Each c In F.Range("Tableau2").Columns(2).Cells
        .UsedRange.Replace c, c(1, 2), xlWhole
    Next
    .Cells(1) = "Catégories"
    .UsedRange.Offset(1).Interior.ColorIndex = xlNone
    .Columns(1).AutoFit 'ajustement largeur
    .ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\Catégories.pdf"
    .Parent.Close False
End With
MsgBox "Le fichier PDF des catégories a été créé"
End Sub
On peut ajouter d'autres choses dans ce document, à toi de voir.

A+
 

Pièces jointes

Vote positif 0 Vote négatif
job75 à dit:
Bonsoir cathodique,

Tu m'as répondu par MP :

Alors peut-être en créant un fichier PDF des catégories :
VB: 
Sub PDF()
Dim F As Worksheet, c As Range
Application.ScreenUpdating = False
Set F = Feuil1 'CodeName, à adapter
With Workbooks.Add.Sheets(1) 'document auxiliaire
    F.Range("Table").ListObject.Range.Columns(3).Copy .Cells(1)
    For Each c In F.Range("Tableau2").Columns(1).Cells
        .UsedRange.Replace c(1, 2), c & c(1, 2), xlWhole
    Next
    .UsedRange.Sort Cells(1), xlAscending, Header:=xlYes
    For Each c In F.Range("Tableau2").Columns(1).Cells
        .UsedRange.Replace c, "", xlPart
    Next
    .UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes 'supprime les doublons
    '---remplacer---
    For Each c In F.Range("Tableau2").Columns(2).Cells
        .UsedRange.Replace c, c(1, 2), xlWhole
    Next
    .Cells(1) = "Catégories"
    .UsedRange.Offset(1).Interior.ColorIndex = xlNone
    .Columns(1).AutoFit 'ajustement largeur
    .ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\Catégories.pdf"
    .Parent.Close False
End With
MsgBox "Le fichier PDF des catégories a été créé"
End Sub
On peut ajouter d'autres choses dans ce document, à toi de voir.

A+
Cliquez pour agrandir...
Bonsoir Job75,

Je te remercie infiniment. C'est intéressant, mais je ne peux aller plus loin pour des raisons de confidentialité des données.

Encore merci. Bonne soirée.
 
Vote positif 0 Vote négatif
cathodique à dit:
C'est intéressant,
Cliquez pour agrandir...
Bon pour centrer horizontalement le PDF :
VB: 
Sub PDF()
Dim F As Worksheet, c As Range
Application.ScreenUpdating = False
Set F = Feuil1 'CodeName, à adapter
With Workbooks.Add.Sheets(1) 'document auxiliaire
    F.Range("Table").ListObject.Range.Columns(3).Copy .Cells(1)
    For Each c In F.Range("Tableau2").Columns(1).Cells
        .UsedRange.Replace c(1, 2), c & c(1, 2), xlWhole
    Next
    .UsedRange.Sort Cells(1), xlAscending, Header:=xlYes
    For Each c In F.Range("Tableau2").Columns(1).Cells
        .UsedRange.Replace c, "", xlPart
    Next
    .UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes 'supprime les doublons
    '---remplacer---
    For Each c In F.Range("Tableau2").Columns(2).Cells
        .UsedRange.Replace c, c(1, 2), xlWhole
    Next
    .Cells(1) = "Catégories"
    .UsedRange.Offset(1).Interior.ColorIndex = xlNone
    .Columns(1).AutoFit 'ajustement largeur
    .PageSetup.CenterHorizontally = True 'centrage
    .ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\Catégories.pdf"
    .Parent.Close False
End With
MsgBox "Le fichier PDF des catégories a été créé"
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

H
  • Question Question
macro boucle de A à IK
Réponses
5
Affichages
1 K
Pierrot93
Pierrot93
Retour