XL 2016 Regroupement selon mots clés

[jipi06]

Bonjour tout le monde

Je souhaite regrouper une série d'environ 10000 lignes (des factures) qui ont des intitulés divers et variés. Pour regrouper je n'ai trouvé qu'un moyen celui des mots clés car on retrouve dans plusieurs centaines de factures des mots communs ....mais.... ils sont rarement à la même place et écrits au singulier ou pluriel.

J'ai essayé d'utiliser des formules de ce type =SI(OU(NB($A2;CHERCHE($G$4;$C2;1));NB($A2;CHERCHE($G$4;$C2;1));"Nom_du_regroupement";"")
ça fonctionne, mais cela ne me convient pas car le nb de mots clés est très important.

Il me faudrait un mode de recherche de type {=SI(OU(A2=Plage_de_mot_clés);1;0)} : ça fonctionne quand il y a correspondance sur la totalité de la cellule mais cela ne fonctionne pas sur du texte libre.

Merci de votre aide

je joins un fichier exemple.
A+

 

[Dranreb]

Bonjour.
Une solution: dans un module standard :

Option Explicit
Private Dic As Dictionary ' Cochez la référence Microsoft Scripting Runtime
Function Selon1erMot(ByVal Texte As String) As String
Dim Td(), L As Long, C As Long, Ts() As String, P As Long
Ts = Split(UCase(Texte))
If Dic Is Nothing Then
   Set Dic = New Dictionary
   Td = [F2:Z2].Resize([F1000].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 Exit For
   Next P
If P <= UBound(Ts) Then Selon1erMot = Dic(Ts(P))
End Function

En C2, à propager sur 42 lignes :

=Selon1erMot($A2)

 

[Jocelyn]

Bonjour le Forum,
Bonjour jipi06, Dranreb 🙂,

Vu que la solution de notre ami Dranreb est de loin bien meilleur qu'une formule, je poste juste pour le fun 😉 une solution par formule matricielle

Cordialement

 

[jipi06]

Formidable
Merci à tous les deux Dranreb & Jocelyn
J'ai le choix et la qualité.

Pour Dranreb, juste une remarque sur le résultat si on met dans les mots clés, un singulier Route et un pluriel Routes Ou bien un mot qui inclus le mot clé type autoroute, le VBA répond vide. CF fichier joint
Il y a peut être un ajustement à faire.

Cette fois ci je prends la formule matricielle, mais le code m’intéresse car vu que les personnes qui vont l'utiliser ne sont pas très excel ils auront tendance à modifier et je préférerai garder le code intact.

Encore bravo

A+

 

[Dranreb]

Vous avez introduit des erreurs en corrigeant une instruction :

'   Td = [h2:aa2].Resize([F1000].End(xlUp).Row - 1).Value
   Td = [G2:AA2].Resize([G1000].End(xlUp).Row - 1).Value

 

[jipi06]

J'avais effectivement rajouté une colonne et mal mis à jour le code , j'ai modifié, mais j'ai toujours le même résultat...

 

[Dranreb]

Réinitialisez le projet VBA: le Dictionary doit être reconstruit.

 

[jipi06]

OK c'est bon
Cela veut dire que si je rajoute des lignes ou colonnes dans le tableau des mots clés je devrai réinitialiser ?

 

[Dranreb]

Oui. On pourrait cependant éventuellement l'éviter en remettant le Dic à Nothing lors d'un changement d'une cellule de cette plage et en transmettant la plage en second paramètre à la fonction. Ce serait encore mieux si le tableau des mots clés avait un ListObject. C'est à dire si sa plage allait faire l'objet d'une mise sous forme de tableau Excel.

 

[jipi06]

...Désolé...là je ne suis plus vraiment! J’ai jamais utilisé ListObject ...

 

[Dranreb]

Mais là on n'aurait pas à l'utiliser en tant que tel, c'est juste la référence auto-ajustante au tableau dans la formule et dans la Worksheet_Change qui serait intéressante.

 

[jipi06]

Peux tu me montre un exemple que j'adapterai ?

 

[Dranreb]

D'abord sélectionner la plage du tableau des mots clés, menu Accueil, groupe Styles, commande Mettre sous forme de tableau.
Dans le Module1:

Option Explicit
Private Dic As Dictionary ' Cochez la référence Microsoft Scripting Runtime
Sub EffaceDic()
   Set Dic = Nothing
   End Sub
Function Selon1erMot(ByVal Texte As String, ByVal RngTab As Range) As String
   Dim Td(), L As Long, C As Long, Ts() As String, P As Long
   Ts = Split(UCase(Texte))
   If Dic Is Nothing Then
      Set Dic = New Dictionary
      Td = RngTab.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 Exit For
      Next P
   If P <= UBound(Ts) Then Selon1erMot = Dic(Ts(P))
   End Function

Dans le Feuil1:

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Not Intersect([Tableau1], Target) Is Nothing Then EffaceDic
   End Sub

Et, j'oubliais, la formule :

=Selon1erMot($A2;Tableau1)

 

[jipi06]

Bonsoir

C'est nickel. Tout fonctionne bien. Je garde le code VBA de Dranreb.

Merci encore à tous les deux

Jipi