Identifier des chaînes de mots communs

Bonjour à tous !

J'ai une problématique sur laquelle je bloque. Je pars d'une base de données comprenant plus de 1000 lignes.

Pour chacune des lignes, j'ai des suites de caractères (des mots), comme ceci:

J'ai besoin d'identifier les cellules ayant en commun 3 mots ou davantage, pour donner cela :

Avez-vous des pistes et/ou des idées ?

Un grand merci pour votre aide !

Alain

bonjour,

une proposition (pour des données en colonne A et B et résultats en colonne C)

Sub motscommuns()
    With ActiveSheet
        dl = .UsedRange.Rows.Count
        For i = 1 To dl - 1
            m1 = Split(.Cells(i, 2))
            For j = i + 1 To dl
                ph = " " & .Cells(j, 2) & " "
                ctr = 0
                 mc = ""
                For k = LBound(m1) To UBound(m1)
                    If InStr(ph, " " & m1(k) & " ") > 0 Then ctr = ctr + 1: mc = mc & " " & m1(k)
                Next k
                If ctr > 2 Then
                    .Cells(i, 3) = .Cells(i, 3) & mc & "(" & .Cells(j, 1) & ")"
                    .Cells(j, 3) = .Cells(j, 3) & mc & "(" & .Cells(i, 1) & ")"
                End If
            Next j
        Next i
    End With
End Sub

on peut compléter la macro en adaptant la ponctuation, la casse, en supprimant certains sur base d'une liste de mots à ne pas prendre en compte, etc...

Hello un essai par powerquery,

Je me suis emmêlé mais ça fonctionne.

Donc maintenant que ça marche je vais chercher un truc optimisé pour m'entraîner

Tu rajoutes tes lignes dans Feuil1 puis tu fais clic droit puis actualiser sur le tableau de l'onglet Tableau 1

@+

Edit : en fait ca ne marche pas

Merci h2so4 ! c'est très proche de ce que j'essaie de faire. J'ai essayé d'adapter votre macro mais sans succès..

Le résultat est le suivant :

J'aurai besoin que la macro ne garde qu'une fois le résultat commun, comme ceci :

==> Eric, Jeanne et Luc ont en commun plus de trois mots "peindre", "étoile", "mer" : donc il les garde en colonne C sans les doublonner. L'idée étant de ne garder que les mots en commun dans la colonne C et non pas concaténer les contenus ayant des mots en commun.

Je vais essayer d'arriver au résultat mais si vous avez l'idée, je reste très preneur!

Mais déjà un grand merci pour votre retour qui m'a fait gagner du temps.

Alain

bonsoir

et dans ce cas-ci qu'est-ce que tu attends comme résultat ?

ou encore autre chose ?

bonjour,

sans réponse à mes questions, je te propose ce bout de code-ci. Sélection de la première série de 3 mots ou plus qui apparait le plus souvent dans les phrases données en colonne B. Comme pour chaque phrase la macro génère toutes les combinaisons de mots possibles, des phrases de plus de 10 mots (10!) vont allonger considérablement le temps d'exécution. La macro prévoit également une fonction de suppression de certains mots, la transformation en minuscules et la suppression des accents et de la ponctuation.

code à mettre dans un nouveau module.

Global dict
Sub motscommuns()

    With ActiveSheet
        dl = .UsedRange.Rows.Count
        Set dict = CreateObject("scripting.dictionary")
        For i = 1 To dl
            phrase = remplacecaractere(.Cells(i, 2))
            m1 = Split(phrase)
            m1 = trie(m1)
            ajoute m1, i
        Next i
        tk = dict.keys
        ti = dict.items
        For i = LBound(tk) To UBound(tk)
            If Val(tk(i)) >= 3 Then If ti(i)(0) > maxc Or (ti(i)(0) = maxc And Val(tk(i)) > maxm) Then maxm = Val(tk(i)): maxc = ti(i)(0): maxi = i: maxk = Mid(tk(i), InStr(tk(i), " "))
        Next i
        v = ti(maxi)
        For i = 1 To v(0)
            .Cells(v(i), 3) = maxk
        Next i
    End With
    Set dict = Nothing
End Sub

Sub ajoute(ByRef mots, ligne, Optional n = 1, Optional ni = 1, Optional s = "")
    olds = s
    For i = ni To UBound(mots)
        If mots(i) <> "" And mots(i) <> " " Then
            s = s & " " & mots(i)
            cle = n & s
            If Not dict.exists(cle) Then
                ReDim v(0)
                v(0) = 0
                dict.Add cle, v
            End If
            v = dict(cle)
            ReDim Preserve v(UBound(v) + 1)
            v(0) = v(0) + 1
            v(v(0)) = ligne
            dict(cle) = v
            If n <= UBound(mots) Then
                ajoute mots, ligne, n + 1, i + 1, s
            End If
            s = olds
        End If
    Next i
End Sub
Function trie(mots)
    trie = Application.Unique(Application.Sort(mots, 1, 1, True))
End Function
Function remplacecaractere(phrase)
    ph = " " & LCase(phrase) & " "
    caro = "éèêëàâäîïôöùûüç.,;:!?"
    carr = "eeeeaaaiioouuuc      "
    For i = 1 To Len(caro)
        ph = Replace(ph, Mid(caro, i, 1), Mid(carr, i, 1))
    Next i
    motsafiltrer = Split(" un , une , de , le , la , les , d , l , en , et , ou , en , sans , au , a , est ,", ",")
    For i = LBound(motsafiltrer) To UBound(motsafiltrer)
        ph = Replace(ph, motsafiltrer(i), " ")
    Next i
    ctr = 0
    For i = 1 To Len(ph)
        c = Mid(ph, i, 1)
        If c = " " Then ctr = ctr + 1 Else ctr = 0
        If ctr < 2 Then nph = nph & Mid(ph, i, 1)
    Next i
    remplacecaractere = nph
End Function

Bonjour,

Je suis navré de ne répondre que maintenant.. petit empêchement.. vraiment navré.

Un grand merci pour le temps consacré et la proposition de solution! je la teste tout de suite.

Merci!