Trouver un mot commun dans des cellules et les grouper ?

Bonjour à tous,

Je suis nouvelle ici. Je travaille dans le référencement naturel pour un site multi-marques et je m'attaque à l'analyse de mots-clés de notre site, ainsi qu'à l'analyse des écarts des mots-clés pour lesquels nos concurrents se positionnent dans les moteurs de recherche et nous non.

Je me retrouve avec des listes de milliers de mots-clés et je voudrais savoir s'il existait une fonction/macro qui pourrait identifier des cellules ayant des mots en communs, en particulier le nom de marques, et qui pourrait grouper ces cellules sous une même étiquette.

Par exemple, dans la liste ci-dessous, on pourrait avoir une étiquette/un groupe "Amazon" avec tous les mots clés qui s'associent à la marque :

4 fois sans frais amazon
4 fois sans frais amazon avis
bon reduction amazon chaussure
bon reduction amazon high tech
bon reduction amazon janvier 2020
bon reduction amazon livre
cadeau 5 euros amazon
cartes cadeaux et codes promotionnels amazon ca
cashback amazon widilo
chèque cadeau amazon gratuit
cheque cadeau amazone code

Bien sûr, je pourrais filtrer en utilisant l'outil de tri/filtre ci-dessous, mais pour cela, il faudrait que je connaisse toutes les marques que je dois rechercher, et même cela pourrait me prendre des heures et des heures.

Connaitrais-vous une formule/une macro qui pourrait ranger les mots clés par groupe ?

Je n'ai pas un super niveau d'excel et je ne saurais pas créer une fonction moi-même malheureusement.

Je joins la liste de mots clés que je voudrais grouper par marques.

Je vous remercie infiniment à l'avance si vous pouvez m'aider ! :)

Bonjour,

Soit ta liste de milliers de mots clés en A2:Axxx...

Les résultats en colonnes D et E : (je n'ai pas intégré le tri car tu peux le faire aisément depuis la feuille une fois les résultats affichés)

Option Explicit

Sub FrequenceMotsCles()
Dim Plage As Range, C As Range, arr, Dict As Object, strTexteComplet As String, temp As String
    Set Plage = Sheets("Sheet 1").Range("A2:A" & Sheets("Sheet 1").Range("A" & Rows.Count).End(xlUp).Row)  'A ADAPTER LA PLAGE CONTENANT LES DONNEES
    For Each C In Plage.Cells
        strTexteComplet = strTexteComplet & " " & C.Text
    Next
    temp = RemovePunctuation(strTexteComplet)
    temp = UCase$(temp)
    arr = Split(temp, " ")
    Set Dict = CreateObject("Scripting.Dictionary")
    FillDictionary Dict, arr
    Range("D1") = "MOTS"
    Range("D2").Resize(Dict.Count) = Application.Transpose(Dict.keys)
    Range("E1") = "FREQ"
    Range("E2").Resize(Dict.Count) = Application.Transpose(Dict.items)
End Sub
Public Function RemovePunctuation(strBook As String) As String
Dim T, i As Integer, temp As String
Const PUNCT As String = """,;:!?."

   T = Split(StrConv(PUNCT, vbUnicode), Chr(0))
   temp = strBook
   For i = LBound(T) To UBound(T) - 1
      temp = Replace(temp, T(i), " ")
   Next
   temp = Replace(temp, "--", " ")
   temp = Replace(temp, "...", " ")
   temp = Replace(temp, vbCrLf, " ")
   RemovePunctuation = Replace(temp, "  ", " ")
End Function
Public Sub FillDictionary(D As Object, a As Variant)
Dim l As Long
   For l = LBound(a) To UBound(a)
      If a(l) <> "" Then D(a(l)) = D(a(l)) + 1
   Next
End Sub

Alt + F8 : FrequenceMotsCles :=> Exécuter

Bonjour Franck, je te remercie infiniment pour ton script !

J'ai essayé comme j'ai pu de l'insérer (je n'ai jamais crée de macro avec VBA) et lorsque je tente de créer un bouton avec le script, je reçois ce genre de message.

Est-ce que c'est normal ?

Merci,

Amélie

Bonjour,

N'étant pas sous Mac, je ne sais pas.

Je t'ai fait un fichier avec la macro intégrée, dis moi si ça fonctionne. Ou pas...

Rebonjour Franck,

J'ai essayé de faire marcher la macro avec ton classeur et il me dit que ça bugge à tel endroit :

Et voilà le message d'erreur que je reçois :

Saurais-tu ce qu'il se passe ? Je suis désolée d'être un peu boulet !

Bonjour,

L'objet Dictionary n'est pas disponible sur mac .

Cdlt,

Ah mince, voilà pourquoi ça n'a pas marché !

Et est-ce que ce genre de macro pourrait être adaptée à Google Sheet ? Au moins, j'y ai accès sur mon ordinateur !

Je ne connais pas Google Sheet mais a priori cette macro ne peut être adaptée car il s'agit d'un autre langage.

Ici, il faudrait "juste" chercher à obtenir le même résultat mais sans l'objet dictionary. Forcément, ça serait plus laborieux...

Cdlt,

Voici une alternative (avec tri et taleau structuré ) sans passer par un dictionnaire :

Sub FrequenceMotsCles()

Dim datas, mots, arrdico
Dim strTexteComplet$, dl&

With ActiveSheet
    If .ListObjects.Count > 0 Then .Range("DICO").Delete Else .Range("D1").CurrentRegion.ClearContents
    dl = .Cells(.Rows.Count, 1).End(xlUp).Row
    datas = Application.Transpose(.Range("A2:A" & dl))  '<<<<<< A ADAPTER LA PLAGE CONTENANT LES DONNEES
    strTexteComplet = Join(datas, " ")
    mots = RemovePunctuation(strTexteComplet)
    arrdico = filldictionary(mots)
    .Range("D1:E1") = Array("MOTS", "FREQ")
    If .ListObjects.Count = 0 Then
        .ListObjects.Add(Source:=.Range("D1:E2"), xllistobjecthasheaders:=xlYes).Name = "DICO" '<<<<< NOM DU PARAMETRE A MODIFIER
    End If
    With .Range("DICO")
        .Resize(UBound(arrdico), UBound(arrdico, 2)) = arrdico
        .Columns.EntireColumn.AutoFit
    End With
    Call TriMots
End With

End Sub

Public Function RemovePunctuation(strBook As String) As Variant

Dim PUNCT, ESPACES, i%

PUNCT = Array(VbNewLine, "--", """", ",", ";", ":", "!", "?", ".")
For i = LBound(PUNCT) To UBound(PUNCT): strBook = Replace(strBook, PUNCT(i), " "): Next i
strBook = UCase(Application.Trim(strBook))
RemovePunctuation = Split(strBook)

End Function

Function filldictionary(datas As Variant)

Dim temp(), i&, j&, n&, doublon As Boolean
ReDim temp(1, 0): n = -1

For i = LBound(datas) To UBound(datas)
    If datas(i) <> "" Then
        For j = LBound(temp, 2) To UBound(temp, 2)
            If datas(i) = temp(0, j) Then
                doublon = True
                temp(1, j) = temp(1, j) + 1
                Exit For
            End If
        Next j
        If Not doublon Then
            n = n + 1
            ReDim Preserve temp(1, n)
            temp(0, n) = datas(i)
            temp(1, n) = 1
        End If
        doublon = False
    End If
Next i

filldictionary = Application.Transpose(temp)

End Function

J'ai adapté le code de Pijaku en passant par des tableaux classiques : La procédure filldictionary est devenue une fonction renvoyant un tableau à 2 colonnes (mots sans doublon et nombre d'occurrences).

La fonction removepunctuation a été modifiée pour renvoyer un tableau des mots après nettoyage du texte car je crois que la fonction strconv qui était utilisée aurait bloqué sur mac. De toute façon, elle ne semble pas nécessaire dans votre cas précis.

Je n'ai pas testé sur mac mais sur windows donc il n'est pas exclu d'avoir une ou deux surprises. Le temps d'exécution est un peu long mais ça marche. De mémoire, je sais qu'il faudra probablement changer le paramètre xllistobjecthasheaders par hasheaders ou xlhasheaders.

Il est possible par ailleurs d'exclure les chiffres ou les mots courts mais je n'ai pas arbitré à ce niveau là...

Cdlt,

Merci, merci, merci à vous deux !!! Ca a marché ! En effet, il fallait changer le paramètre xllistobjecthasheaders par hasheaders, mais ça a fonctionné !

Je vous suis éternellement reconnaissante ! Comment pourrais-je vous remercier ?

Amélie

Bonjour,

Je sais pas... en m'envoyant un chèque à 5 zéros par exemple ?

Je suis content que ça marche et ça servira peut-être à d'autres, c'est l'essentiel !

Bon réveillon !

Cdlt,

Ah ah malheureusement, je n'ai pas les 5 zéros !

Mais en effet, ça me servira énormément et je pourrais le partager avec mes amis SEO si ça ne vous dérange pas. Ca leur fera économiser beaucoup de temps.

Bon réveillon à vous aussi ! Le mien sera très calme, à regarder des films.