XL 2016 Regroupement selon mots clés

jipi06

XLDnaute Junior
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+
 

Pièces jointes

  • TEST Regroupement FACTURES.xlsx
    68.2 KB · Affichages: 27

Dranreb

XLDnaute Barbatruc
Bonjour.
Une solution: dans un module standard :
VB:
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 :
Code:
=Selon1erMot($A2)
 

Jocelyn

XLDnaute Barbatruc
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
 

Pièces jointes

  • TEST Regroupement FACTURES.xlsx
    68.7 KB · Affichages: 19

jipi06

XLDnaute Junior
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+
 

Pièces jointes

  • TEST Regroupement FACTURES v2.xlsm
    75 KB · Affichages: 22

Dranreb

XLDnaute Barbatruc
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.
 

Dranreb

XLDnaute Barbatruc
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:
VB:
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:
VB:
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 :
Code:
=Selon1erMot($A2;Tableau1)
 

Discussions similaires

Statistiques des forums

Discussions
311 729
Messages
2 081 970
Membres
101 852
dernier inscrit
dthi16088