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

cathodique · 1 Septembre 2024

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

klin89 · 1 Septembre 2024

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

cathodique · 2 Septembre 2024

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

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.

cathodique · 2 Septembre 2024

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

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é.

cathodique · 2 Septembre 2024

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.

job75 · 2 Septembre 2024

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+

job75 · 2 Septembre 2024

Si l'on veut paramétrer en H1 le sens du tri :

VB:

[Table].Sort Columns(3), IIf([H1] = "Décroissant", xlDescending, xlAscending), Header:=xlYes

cathodique · 3 Septembre 2024

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+

Bonjour @job75 ,

Merci beaucoup. Je ne veux rien modifier à mon tableau initial.

job75 · 3 Septembre 2024

Bonjour cathodique,

cathodique à dit:
Merci beaucoup. Je ne veux rien modifier à mon tableau initial.

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+

job75 · 4 Septembre 2024

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.

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+

cathodique · 4 Septembre 2024

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+

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.

job75 · 4 Septembre 2024

cathodique à dit:
C'est intéressant,

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

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

cathodique

XLDnaute Barbatruc

Pièces jointes

klin89

XLDnaute Accro

cathodique

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

cathodique

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

cathodique

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires