Suite fil "RECHERCHE MOTS CLES" : Fonction de Dranreb (supprimer redondance)

zebanx

XLDnaute Accro
Bonjour à tous,

Cette demande fait suite à la remarquable réponse apportée en VBA sur ce fil par DRANREB (merci :)) par l'intermédiaire d'une fonction (et jocelyn pour la formule à remercier aussi)
https://www.excel-downloads.com/threads/regroupement-selon-mots-clés.20026877
Réalisé sur ce fil : affectation d'un mot clé présent dans la cellule à une référence dans une BDD (goudron -> route...).

Souhait :
Si un libellé de facture repris en colonne "A" concerne plusieurs catégories potentiellement, il faudrait que la restitution fournisse l'ensemble des mots clés retrouvés (après, je me débrouille avec un split).
J'ai un peu modifié ce code en conséquence mais s'il y a redondance pour un mot clé, comment faire pour le supprimer svp ?

Vous en remerciant par avance,
xl-ment
zebanx

VB:
Function RECHMC2(ByVal Texte As String) As String
'code repris sur fonction de DRANREB
Dim Td(), L As Long, C As Long, Ts() As String, P As Long, tour%
Ts = Split(UCase(Texte))
tour = 1

If Dic Is Nothing Then
   Set Dic = New Dictionary
   Td = [G2:AA2].Resize([G1000].End(xlUp).Row - 1).Value
   For L = 1 To UBound(Td, 1)
      For C = 2 To UBound(Td, 2)
         If IsEmpty(Td(L, C)) Then Exit For
         Dic(UCase(Td(L, C))) = Td(L, 1)
         Next C, L
         End If
   For P = 0 To UBound(Ts)
   If Dic.Exists(Ts(P)) Then
        If tour = 1 Then
        RECHMC2 = Dic(Ts(P))
        tour = tour + 1
        Else
        RECHMC2 = RECHMC2 & "-" & Dic(Ts(P))
        End If
   End If
   Next P
End Function
 

Pièces jointes

  • rech_mots_clés.xls
    48.5 KB · Affichages: 24
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonjour.
Comme ça, ça a l'air pas mal :
VB:
Function RECHMC2(ByVal Texte As String) As String
Dim Td(), L As Long, C As Long, Ts() As String, P As Long, N As Long, Q As Long
If Dic Is Nothing Then
   Set Dic = New Dictionary
   Td = [G2:AA2].Resize([G1000].End(xlUp).Row - 1).Value
   For L = 1 To UBound(Td, 1)
      For C = 2 To UBound(Td, 2)
         If IsEmpty(Td(L, C)) Then Exit For
         Dic(UCase(Td(L, C))) = Td(L, 1)
         Next C, L: End If
Ts = Split(UCase(Texte))
N = -1
For P = 0 To UBound(Ts)
   If Dic.Exists(Ts(P)) Then
      N = N + 1: Ts(N) = Dic(Ts(P))
      For Q = N - 1 To 0 Step -1
         If Ts(Q) = Ts(N) Then Exit For
         Next Q: If Q >= 0 Then N = N - 1
      End If: Next P
If N < 0 Then Exit Function
ReDim Preserve Ts(0 To N)
RECHMC2 = Join(Ts, "-")
End Function
 

zebanx

XLDnaute Accro
Bonjour Dranreb

C'est impeccable et je te remercie pour ce code modifié.:)

Par contre, en essayant de comprendre la fin de boucle, je n'arrive pas à comprendre comment elle fonctionne.
Ci-joint ma zone de "perdition" sur chaque changement de mot sur une seule ligne, ce sera plus clair il me semble.
Cette ligne là en particulier me laisse perdu dès sa première exécution
For Q = N - 1 To 0 Step -1

Pourrais-tu STP corriger le tableau et m'apporter par une info-bulle (le plus simple) peut-être quelques précisions quand tu auras un moment ?

Je t'en remercie par avance.

Bonne fin de journée
zebanx
 

Pièces jointes

  • dde_dranreb.xls
    32 KB · Affichages: 24

Dranreb

XLDnaute Barbatruc
Le principe est simple non ?
Je regarde dans tous les Ts(Q) précédents (-1<Q<N) si je n'y ai pas déjà mis cette catégorie, et à la fin si on en est effectivement sorti avec un Q>=0 j'annule l'ajout de 1 à N où je l'avais mis en attendant, pour qu'il soit écrasé la fois d'après ou bien oublié par le Redim Preserve à la fin.
Ce serait peut-être plus clair comme ça ?
VB:
      For Q = 0 To N - 1
         If Ts(Q) = Ts(N) Then Exit For
         Next Q: If Q < N Then N = N - 1
Il faut savoir que si une boucle va jusqu'au bout, son compteur vaut en sortie un pas de plus que la valeur de fin demandée.
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
P va en général plus vite que N, au pire N avance aussi vite que P. On peut donc réutiliser Ts en y remplaçant au fur et à mesure en N les mots clés trouvés en P par les catégories correspondantes si elles n'ont pas déjà été mise en un Q précédent.
 

Discussions similaires