Find Keyword Density in Rows and Columns

[MarkoX50]

Hi, I have a workbook that has 1 column (Column A) with 8000 Rows. Each Cell contains a string of words ranging from 1 word to 100 words. I am looking for a formula that can create a list of most common words (keywords) in each cell across the column. Ideally, i would like to know the most repeated words in the entire column.

Can this be done with a formula or can it only be done via VBA, if so, can someone please assist me with the code or formula.

Much Appreciated.

 

[MarkoX50]

Thank you Mick. Worked 100% and is what I'm looking for.

 

[MickG]

You're welcome

 

[MarkoX50]

Hi Mick, So an error appeared when i inserted 20000 records.

(Run Time Error '13': Type Mismatch)

Can you help with this? Thanks

 

[MickG]

Try this, It should give the count of all words (in Descending order).

[COLOR="Navy"]Sub[/COLOR] MG24Aug11
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Sp [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Variant, NoStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] i, j, sRay [COLOR="Navy"]As[/COLOR] Variant, Temp1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] temp2 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
NoStr = "#cat#dog#the#" '[COLOR="Green"][B] Alter/Add words not to include here !!!![/B][/COLOR]
    [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
        [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Sp = Split(Dn.Value, " ")
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Sp
            [COLOR="Navy"]If[/COLOR] Not R = vbNullString And InStr(NoStr, "#" & R & "#") = 0 [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]If[/COLOR] Not .Exists(R) [COLOR="Navy"]Then[/COLOR]
                    .Add R, 1
                [COLOR="Navy"]Else[/COLOR]
                    .Item(R) = .Item(R) + 1
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] Dn
sRay = Application.Transpose(Array(.Keys, .items))
[COLOR="Navy"]For[/COLOR] i = 1 To UBound(sRay, 1)
    [COLOR="Navy"]For[/COLOR] j = i To UBound(sRay, 1)
        [COLOR="Navy"]If[/COLOR] sRay(j, 2) > sRay(i, 2) [COLOR="Navy"]Then[/COLOR]
            Temp1 = sRay(i, 1)
            temp2 = sRay(i, 2)
                sRay(i, 1) = sRay(j, 1)
                sRay(i, 2) = sRay(j, 2)
                    sRay(j, 1) = Temp1
                    sRay(j, 2) = temp2
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] j
[COLOR="Navy"]Next[/COLOR] i
Range("B1").Resize(UBound(sRay, 1), 2) = sRay
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[MarkoX50]

Hi Mick,

I still get the same error message and the above code makes the process much longer. I prefer the previous code with the top 50. My data has special characters and numbers as well. Will that cause the error?

 

[MickG]

Is it possible to send your file, possibly using "Box.com" (free file sharing)

 

[MarkoX50]

Unfortunately not due to security protocols on my side. Is it just too much data?

 

[MickG]

Somewhere the amount of data would seem to be having that effect with the first code, although I have tried the latest code on over 20k rows, without a problem, so could be something else.!!!
You could try doing half of the data ,if that works try the other half, if both work it looks like the amount of data. Could be the "Application.Transpose", That has limitations
Do you get a line it fails on in the code, that's a good pointer !!

 

[MarkoX50]

Thanks Mick. I found the issue. There was a formula in the data which was directing to a redundant location. I changed it and it worked 100%.

Awesome stuff. Thanks again.

 

[MickG]

Great, Glad you've got it working
Regrds Mick