[VBA] Objet dictionary sans symboles trié

Le 05/11/2020 à 11:50

Bonjour le forum :)

J'essaie d'analyser une base de données où des utilisateurs laisses des commentaires. Je me suis donc créer une macro qui permet de mettre dans un dictionnaire tous les mots (.Keys) et de les comptabiliser, le résultat étant aussi stocké dans le dictionnaire (.Items).

Jusque là tout fonctionne, mais je bute sur une optimisation du code. Je cherche , avant d'analyser un mot, à retirer tous symboles potentiels.

Je donne un exemple ci-dessous :

  • Dans une cellule se trouve la phrase "Coucou, :) comment ça va ?"
  • Le code va regarder chaque mot les uns après les autres (j'utilise comme séparateur le " ")
  • Sur le premier interval "Coucou," il y a une ","
  • je veux donc obtenir "Coucou"

Et là vous avez envie de me dire "utilise Replace !" Replace("Coucou,",",",""), et bien c'est ce que j'ai fait et ça ne marche pas

Bref je comprend pas pourquoi 

Option Explicit

Sub DictionnaireV2()
Dim f As Worksheet
Dim h As Long, i As Long, j As Long, k, l, cpt As Long, Epure As Long, DernLig As Long
Dim LongExt As Integer
Dim tempo As String, Decoupe() As String
Dim Mots As Variant, Plage As Variant, Symb As Variant
Dim CentPourCent As Long, Boucle As Long
Dim Dico, SymbTBL()

    MsgBox "La procédure suivante permet d'identifier les taches les plus récurrentes et mettre à jour le PARETO TOP10.", vbInformation, "Extraction"
    Set f = ThisWorkbook.Worksheets(Feuil1.Name)
    Set Dico = CreateObject("Scripting.Dictionary")
    SymbTBL = Array(" ", ",", "?", ";", ".", "/", ":", "!", "§", "%", "*", "µ", "+", "=", "}", ")", "°", "]", "@", "_", "\", "-", "|", "[", "(", "'", "{", "&", """")
    LongExt = Application.InputBox("Longueur minimum de caractère à extraire ?", "Extraction", 1, Type:=1)
    If LongExt = 0 Then Exit Sub
    DernLig = f.Range("A" & f.Rows.Count).End(xlUp).Row
    Plage = f.Range("J2:J" & DernLig)
    'With UserForm2
    '    .Show 0
    '    CentPourCent = .Label1.Width - 3
        For i = LBound(Plage) To UBound(Plage)
     '       DoEvents
     '       UserForm2.Label2.Width = i * CentPourCent / UBound(Plage)
     '       .Caption = "Extraction des termes : " & Format((i * CentPourCent / UBound(Plage)) / CentPourCent, "##0.00%")
            If f.Range("Q" & i + 1) = "NON" Then
                Decoupe = Split(Plage(i, 1), " ")
                For j = LBound(Decoupe) To UBound(Decoupe)
                    For Each Symb In SymbTBL
                        tempo = Replace(Decoupe(j), Symb, "")
                    Next Symb
                    If tempo <> "" And Len(tempo) > LongExt Then Dico(UCase(tempo)) = ""
                Next j
            End If
        Next i
        For Each Mots In Dico.keys
            cpt = 0
            For k = LBound(Plage) To UBound(Plage)
                Decoupe = Split(Plage(k, 1), " ")
                For l = LBound(Decoupe) To UBound(Decoupe)
                    For Each Symb In SymbTBL
                        tempo = UCase(Replace(Decoupe(l), Symb, ""))
                    Next Symb
                    If tempo = Mots Then cpt = cpt + 1
                Next l
            Next k
            Dico.Item(Mots) = cpt
            Debug.Print Mots & " - " & Dico.Item(Mots)
        Next Mots
    'End With
End Sub
13dico.xlsm (23.52 Ko)

Par avance, merci de l'interet porté au sujet !

Le 05/11/2020 à 12:19

Bonjour,

Et "la bible" elle dit quoi la dessus ?

@ bientôt

LouReeD

Le 05/11/2020 à 12:49

LouReeD et bien sois je n'ai pas cherché au bon endroit soit je suis aveugle mais je n'ai rien trouvé qui m'a permis d'avancer. c'est pourtant pas la première fois que je fais de la manipulation d'une chaine de caractères

Le 05/11/2020 à 13:04

J'ai trouvé mon problème, ça n'a rien à voir avec les chaines de caractères mais plutôt à un enchainement pas logique :

Dans ce cas là à chaque boucle je réinitialisais ma variable à sont état d'origine et ne sauvegardais pas la suppression des cartères !

Decoupe = Split(Plage(i, 1), " ")
                For j = LBound(Decoupe) To UBound(Decoupe)
                    For Each Symb In SymbTBL
                        tempo = Replace(Decoupe(j), Symb, "")' <===PAS BIEN
                    Next Symb
                    If tempo <> "" And Len(tempo) > LongExt Then Dico(UCase(tempo)) = ""
                Next j

Dans ce cas là ça marche :

                Decoupe = Split(Plage(i, 1), " ")
                For j = LBound(Decoupe) To UBound(Decoupe)
                    tempo = Decoupe(j)'<===BIEN
                    For Each Symb In SymbTBL
                        tempo = Replace(tempo, Symb, "")'<===BIEN
                    Next Symb
                    If tempo <> "" And Len(tempo) > LongExt Then Dico(UCase(tempo)) = ""
                Next j
Le 05/11/2020 à 18:10

Bravo !

Comme dit la signature d'une membre : "A force de chercher on fini par trouver !"
ou un truc de ce genre

@ bientôt

LouReeD

Le 06/11/2020 à 11:56

Tout à fait LouReeD

Pour ce qui passerais ici, voilà mon code final :

Option Explicit

Sub DictionnaireV2()
Dim f As Worksheet, f2 As Worksheet
Dim h As Long, i As Long, j As Long, k, l, cpt As Long, Epure As Long, MAX As Long, DernLig As Long
Dim LongExt As Integer
Dim tempo As String
Dim Dico As Object
Dim CentPourCent As Long, Boucle As Long
Dim Decoupe() As String
Dim SymbTBL()
Dim Symb As Variant, Mots As Variant, Plage As Variant

    MsgBox "La procédure suivante permet d'identifier les taches les plus récurrentes et mettre à jour le PARETO TOP10.", vbInformation, "Extraction"
    Set f = ThisWorkbook.Worksheets(Feuil1.Name)
    Set f2 = ThisWorkbook.Worksheets(Feuil7.Name)
    Set Dico = CreateObject("Scripting.Dictionary")
    SymbTBL = Array(" ", ",", "?", ";", ".", "/", ":", "!", "§", "%", "*", "µ", "+", "=", "}", ")", "°", "]", "@", "_", "\", "-", "|", "[", "(", "'", "{", "&", """")
    LongExt = Application.InputBox("Longueur minimum de caractère à extraire ?", "Extraction", 6, Type:=1)
    If LongExt = 0 Then Exit Sub
    DernLig = f.Range("A" & f.Rows.Count).End(xlUp).Row
    Plage = f.Range("J2:J" & DernLig)
    With UserForm2
        .Show 0
        CentPourCent = .Label1.Width - 3
        For i = LBound(Plage) To UBound(Plage)
            DoEvents
            .Label2.Width = i * CentPourCent / UBound(Plage)
            .Caption = "Extraction des termes : " & Format((i * CentPourCent / UBound(Plage)) / CentPourCent, "##0.00%")
            If f.Range("Q" & i + 1) = "NON" Then
                Decoupe = Split(Plage(i, 1), " ")
                For j = LBound(Decoupe) To UBound(Decoupe)
                    tempo = Decoupe(j)
                    For Each Symb In SymbTBL
                        tempo = Replace(tempo, Symb, "")
                    Next Symb
                    If Len(tempo) >= LongExt Then Dico(UCase(tempo)) = Dico(UCase(tempo)) + 1
                Next j
            End If
        Next i
        Do While Dico.Count > 20
            If MsgBox("Le programme a répertorié " & Dico.Count & " termes. Il est fortement recommandé d'effectuer un épurage de la liste. " & _
            "Dans le cas contraire, le PARETO TOP10 risque d'être illisible. Cette opération peux durer plusieurs minutes." & Chr(10) & Chr(10) & "Voulez-vous épurer la liste ?", vbExclamation + vbYesNo, "Epurage") = vbYes Then
                Epure = Application.InputBox("Retirer de la liste d'extraction tous les termes dont la récurrence " & Chr(10) & _
                "est strictement inférieur à :", "Epurage", 3, Type:=1)
                cpt = 0
                .Label2.Width = 0
                MAX = Dico.Count
                For Each Mots In Dico.keys
                    cpt = cpt + 1
                    .Label2.Width = cpt * CentPourCent / MAX
                    .Caption = "Extraction des termes : " & Format((cpt * CentPourCent / MAX) / CentPourCent, "##0.00%")
                    If Dico.Item(Mots) < Epure Then Dico.Remove (Mots)
                Next Mots
            Else
                Exit Do
            End If
        Loop
        MAX = 1
        f2.UsedRange.Clear
        cpt = 1
        .Label2.Width = cpt * CentPourCent / MAX
        .Caption = "Nettoyage ... : " & Format((cpt * CentPourCent / MAX) / CentPourCent, "##0.00%")
        Application.Wait (Now + TimeValue("00:00:01"))
        MAX = 2
        f2.Range("A1").Resize(Dico.Count) = Application.WorksheetFunction.Transpose(Dico.keys)
        cpt = 1
        .Label2.Width = cpt * CentPourCent / MAX
        .Caption = "Importation ... " & Format((cpt * CentPourCent / MAX) / CentPourCent, "##0.00%")
        f2.Range("B1").Resize(Dico.Count) = Application.WorksheetFunction.Transpose(Dico.items)
        cpt = 2
        .Label2.Width = cpt * CentPourCent / MAX
        .Caption = "Importation ... " & Format((cpt * CentPourCent / MAX) / CentPourCent, "##0.00%")
        Application.Wait (Now + TimeValue("00:00:01"))
    End With
    Unload UserForm2
    MsgBox "Mise à jour du PARETO TOP10 terminée.", vbInformation, "UpDate"
End Sub
Le 06/11/2020 à 21:52

Bonsoir,

merci @ vous pour ce partage qui clôture avec brio ce fil !

@ bientôt

LouReeD

Le 06/11/2020 à 23:55

Bonsoir,

@GGautier je lisais juste le fil, je vois que tu as pas mal de variables, sache que pour une petite optimisation tu peux écrire les variables qui ont le même type sous cette forme

Dim x, y, z As Byte

Rien d'exceptionnel mais un petit plus pour la lisibilité et pour l'écriture !

Bonne soirée,

Baboutz

Le 07/11/2020 à 00:28

Bonjour,

erreur Baboutz, pas en vba.
Il faut toutes les typer individuellement.
eric

Le 07/11/2020 à 00:31

Exact. Je croyais aussi que c'était le cas mais, si on fait comme ça, tous sauf le dernier sont déclarés en variant. Et ça peut poser problème dans certaines conditions.

Cas rencontré pas plus tard qu'il y a une heure.

Le 07/11/2020 à 00:45

Oh mince, moi qui était si sûr ahah !

Merci alors, je vais m'empresser de corriger mes macros !

Bonne soirée,

Baboutz

Le 07/11/2020 à 01:17

Par contre tu as Deftype qui te permet de définir le type de toutes les variables commençant entre telle et telle lettre.
Ex : DefLng I-M
Mais bon, c'est le genre de truc qu'on oublie rapidement
eric

Le 07/11/2020 à 21:35

Merci Éric, je ne connaissais pas cette fonction !

Je me suis renseigné, elle peux être pratique dans certain cas mais ça reste rare.

Le 09/11/2020 à 09:16

Merci à vous pour ces précisions, il est vrai que je m'ettais déjà posé cette question, alors dans le doute je typpais toutes mes variables, je faisais bien du coup ^^ Au moins une interrogation en moins !

Rechercher des sujets similaires à "vba objet dictionary symboles trie"