Multi Keyword Phrase Finding Macro

[John Caines]

Hello All.
I have a large keyword list in a sheet called "AllKWs" In ColA from A3 downwards).

What I'd like to be able to do is this, which I'm sure will be complicated, but I will explain.

Say keyword phrase sheet has 25,000 rows of data (could be more/could be less).
I click an assigned macro button.
A pop up box appears.
I type in a word or words I'd like some info on, so for example I type in a word or words like "car rent"

It then returns for me on a new sheet called "Multi Keywords" a lot of data on this sheet, which would hopefully be as follows:

All Row 1 will contain Column headings
All row 2 will contain Total Counts (I'll explain in a minute this row)

So, all data to be returned from Row 3 downwards.
OK, as to the data to be returned.
All returned data In all Columns to show data in descending order by No of occurrances/appearances

Col A (From A 3 downwards) = The actual number of 2 word appearances (In this example that contain the words "car rent"
In Col B = All 2 word Phrases Containing ("In this example "Car Rent")
(As a note, In this example, ColA (CellA3) could only show the number"1" and ColB (B3)could only show the phrase "Car Rent") once. (As there isn't no other possible combination).
In Col C =The actual number of 3 word appearances listed in descending order That contain the word "Car rent"
In Col D =All 3 word Phrases Containing "Car Rent"
In Col E =The actual number of 4 word appearances containing "Car Rent" listed in descending order
In Col F =All 4 word Phrases Containing "Car Rent"
In Col G =The actual number of 5 word appearances listed in descending order
In Col H =All 5 word Phrases Containing "Car rent"
In Col I =The actual number of 6 word appearances listed in descending order
In Col J =All 6 word Phrases Containing "Car Rent"
In Col K=The actual number of 7 word appearances listed in descending order
In Col L = All 7 word Phrases Containing "Car Rent"
In Col M=The actual number of 8 word appearances listed in descending order
In Col N=All 8 word Phrases Containing "Car Rent"
In Col O=The actual number of 9 word appearances listed in descending order
In Col P=All 9 word Phrases Containing "Car Rent"
In Col Q = The actual number of 10 word appearances listed in descending order
In Col R= All 10 word Phrases Containing "Car Rent"

Easy huh?
Actually if anyone can crack this I really do take my hat of to them.
OK,A few more points,
Cells B2,D2,F2,H2,J2,L2,N2,P2,R2, All contain the word "Total:" and if the macro can fill in the number as appropriate.
So for example Cell L2 (For 7 word phrases) would say something like "Total:42" (If in Col L From L3 downwards the macro found 42 7 word phrases that contained the words "Car rent"

Ok, Cells A2,C2,E2,G2,I2,K2,M2,O2,Q2 All these cells will contain the word "Total". So these cells would list the combined total number of occurrances of all the phrases.
So for example cell K2 might say "Occur:324" as the total number of occurances of 7 word phrases that had the words "Car rent"in.

OK. as an example, I will post a code that Jindon wrote for me sometime ago. I'm posting this now, as it is very similar in what I would like this macro to be able to do, and might help as I'm sure this 1 will be complicated. This 1 looks for a phrase, returns by No of occurrances etc, but for all the combinations (Word lengths) within the Keyword phrase list, rather than what I'm asking for now, which splits them into Number of words columns.
Here it is anyway:

Sub NicheKeywordFinder()
    Dim a, dic As Object, X, myTxt As String, b(), c(), n As Long, i As Long, e, s, myTotal As Long
    myTxt = InputBox("HuaHinCarRental - Niche Keyword Finder") 'change to suit
    If Len(myTxt) = 0 Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    ReDim b(1 To Rows.Count, 1 To 1): ReDim c(1 To Rows.Count, 1 To 3)
    With Sheets("All KWs") 'change to suit
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
    End With
    With CreateObject("VBScript.RegExp")
        .Pattern = "[\n\f\r\t\v]|(\b([a-z0-9:\;&\+-/\|\\]{1}|200|\d{2}|by|do|fe|ga|not|how|we|from|get|theat|with|a(ll|m|n(d|y)?|t)|c(a|o|om)|o(f|n|r)|i(f|s|t)|m(e|y)|e(a|d|n)|hi|i(d|l|v)|the|for|(g|t)o|in|up|you(r)?(s)?|l(ike|ook))\b)"
        .Global = True
        .IgnoreCase = True
        For Each e In a
            If UCase(myTxt)<> "ALL" Then
                If InStr(1, e, myTxt, 1) > 0 Then
                    i = i + 1: b(i, 1) = e
                    X = Split(.Replace(Trim(e), ""))
                    If IsArray(X) Then
                        For Each s In X
                            If s<> "" And s<> " " Then
                                If Not dic.Exists(s) Then
                                    n = n + 1
                                    dic.Add s, n
                                End If
                                c(dic(s), 1) = s: c(dic(s), 3) = c(dic(s), 3) + 1
                            End If
                        Next
                    Else
                        If Not dic.Exists(Trim(e)) Then
                            n = n + 1: dic.Add e, n
                        End If
                        c(dic(e), 1) = e: c(dic(e), 3) = c(dic(e), 3) + 1
                    End If
                End If
            Else
                i = i + 1: b(i, 1) = e
                    X = Split(.Replace(Trim(e), ""))
                    If IsArray(X) Then
                        For Each s In X
                            If s<> "" And s<> " " Then
                                If Not dic.Exists(s) Then
                                    n = n + 1
                                    dic.Add s, n
                                End If
                                c(dic(s), 1) = s: c(dic(s), 3) = c(dic(s), 3) + 1
                            End If
                        Next
                    Else
                        If Not dic.Exists(Trim(e)) Then
                            n = n + 1: dic.Add e, n
                        End If
                        c(dic(e), 1) = e: c(dic(e), 3) = c(dic(e), 3) + 1
                    End If
            End If
        Next
    End With
    Set dic = Nothing: Erase a
    If i< 1 Then
        MsgBox "Not Found"
        Exit Sub
    End If
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("NicheKWresults").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Sheets.Add.Name = "NicheKWresults"
    With Sheets("NicheKWresults")
        With .Cells.Font
            .Name = "Tahoma"
            .Size = 9 '<- Font size for entire sheet here
        End With
        With .Rows(1)
            .RowHeight = 21
            .Font.Size = 11
            .Font.Bold = True
        End With
        With .Range("a1")
            With .Resize(, 7)
                .Value = Array("Phrases That Include: " & myTxt, "", "Unique Keywords", "", "No. Of Appearances", "", "% Of Appearances")
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Interior.Color = RGB(51, 102, 255)
            End With
            .Offset(4).Resize(i).Value = b
            With .Offset(4, 2).Resize(n, 3)
                .Value = c
                .Sort key1:=.Range("c1"), order1:=xlDescending, Header:=xlNo
                myTotal = [sum(NicheKWresults!e:e)]
                With .Offset(, 4).Resize(, 1) '<- this is Col.G
                    .FormulaR1C1 = "=round(rc[-2]/" & myTotal & ",4)"
                    .NumberFormat = "0.00 %"
                End With
                With .Offset(, -2).Resize(, 7)
                    .FormatConditions.Add Type:=xlExpression, Formula1:="=mod(row(),2)=0"
                    .FormatConditions(1).Interior.Color = RGB(240, 240, 240)
                End With
            End With
            With .Offset(1).Resize(, 5)
                .Value = Array("Total Phrases: " & i, "", "Total: " & n, "", "Total: " & myTotal)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With
        End With
        .Range("a:g").EntireColumn.AutoFit
        .Select
        .Range("a3").Select
    End With
    ActiveWindow.FreezePanes = True
End Sub

Finally, I will add a screen capture as to how the sheet will look, formatted, so you have a visual idea.
As a note, the column widths are "12" (For Occur) and "25" for "Word Phrases" columns

Advanced Keyword Sheet.xlsm
	A	B	C	D	E	F	G	H	I	J
1	Occur	2WordPhrases	Occur	3WordPhrases	Occur:	4WordPhrases	Occur	5WordPhrases	Occur	6WordPhrases
2	Total:	Total:	Total:	Total:	Total:	Total:	Total:	Total:	Total:	Total:
3
4
5
6
7
8
9
10
Multi Keywords

I hope this all makes sense.
I know this will be real difficult I'm sure.
But just maybe someone can crack this.
Many Thanks
John Caines

 

[jindon]

Sub NicheKeywordFinder2()
    Dim a, dic As Object, x, myTxt As String, e, myMax As Long, myMin As Long, n As Long
    myTxt = InputBox("HuaHinCarRental - Niche Keyword Finder") 'change to suit
    If Len(myTxt) = 0 Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    ReDim b(1 To Rows.Count, 1 To Columns.Count)
    myMin = UBound(Split(myTxt)) + 1
    With Sheets("All KWs") 'change to suit
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
    End With
    For Each e In a
        If InStr(1, e, myTxt,1)>0 Then
            x = UBound(Split(e)) + 1
            If Not dic.exists(x) Then dic.add x, 0
            b(dic(x)+1, x) = e : dic(x) = dic(x) + 1
            myMax = WorksheetFunction.Max(myMax, x)
        End If
    Next
    Erase a
    If x = 0 Then MsgBox "No match" : Exit Sub
    ReDim Preserve b(1 To UBound(a,1), 1 To myMax)
    maxR = WorksheetFunction.Max(.items)
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Multi KeyWords").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Sheets.Add.Name = "Multi KeyWords"
    With Sheets("Multi KeyWords").Range("a1")
         For i = 1 To UBound(b,2)
              If dic.exists(i) Then
                   .Offset(,n).Value = "The actual # of " & myMin & " word appearances"
                   .Offset(1,n).Value = "Total : " & dic(i)
                   .Offset(1,n+1).Resize(myMax).Value = _
                                WorksheetFunction.Index(b, 0, i)
                   n = n + 2
               End If
         Next
    End With
End Sub

Let's see if this works...

 

[John Caines]

Got an error Jindon

Sorry Jindon, got an error.
It said
======================
"Compile error:
Invalid or Unqualified reference"
======================

when I hit debug this was highlighted in grey

(.items)

which was in this line of code;

maxR = WorksheetFunction.Max(.items)

The top line is in yellow also,, which is;

Sub NicheKeywordFinder2()

Jindon, you know I know absolutely nothing about code, but for some reason I just thought I'd try taking the "." out of the "(.items)" that was highlighted grey. No idea why I did, but I just thought I'd try.

Maybe that dot needs to be in there I'm not sure, but when I did take out the dot, and reset the macro, the pop up box did display
I entered a keyword phrase, but then got this error saying;
============
"Run-time error '7'
Out of memory
============
I clicked debug and this line of code was highlighted in yellow;

ReDim b(1 To Rows.Count, 1 To Columns.Count)

Any ideas Jindon??
Many thanks though,
It's looking promising
all the best
John Caines

 

[Krishnakumar]

Hi,

Replace

maxR = WorksheetFunction.Max(.items)

with

maxR = WorksheetFunction.Max(dic.items)

also

replace

ReDim b(1 To Rows.Count, 1 To Columns.Count)

with

ReDim b(1 To UBound(a, 1), 1 To 100)

replace 100 with possible no. of result columns

and place the above line of code just above this

For Each e In a

line.



HTH

 

[jindon]

Sub NicheKeywordFinder2()
    Dim a, dic As Object, x, myTxt As String, e, myMax As Long, myMin As Long, n As Long
    myTxt = InputBox("HuaHinCarRental - Niche Keyword Finder") 'change to suit
    If Len(myTxt) = 0 Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    ReDim b(1 To Rows.Count, 1 To 20) '<- here
    myMin = UBound(Split(myTxt)) + 1
    With Sheets("All KWs") 'change to suit
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
    End With
    For Each e In a
        If InStr(1, e, myTxt,1)>0 Then
            x = UBound(Split(e)) + 1
            If Not dic.exists(x) Then dic.add x, 0
            b(dic(x)+1, x) = e : dic(x) = dic(x) + 1
            myMax = WorksheetFunction.Max(myMax, x)
        End If
    Next
    Erase a
    If x = 0 Then MsgBox "No match" : Exit Sub
    ReDim Preserve b(1 To UBound(a,1), 1 To myMax)
    maxR = WorksheetFunction.Max(dic.items) '<- here
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Multi KeyWords").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Sheets.Add.Name = "Multi KeyWords"
    With Sheets("Multi KeyWords").Range("a1")
         For i = 1 To UBound(b,2)
              If dic.exists(i) Then
                   .Offset(,n).Value = "The actual # of " & myMin & " word appearances"
                   .Offset(1,n).Value = "Total : " & dic(i)
                   .Offset(1,n+1).Resize(myMax).Value = _
                                WorksheetFunction.Index(b, 0, i)
                   n = n + 2
               End If
         Next
    End With
End Sub

Thanks Kris

 

[John Caines]

error I'm affraid on 1 line

Many Thanks To Krishnakumar and Jindon for helping me here.

OK, here's what I've got so far.
First I tried your amendments Krishnakumar to Jindons posted code.
I made the changes as you suggested, I hope I did insert them ok
Anyway, in this version the code then looked like this

Sub NicheKeywordFinder2()
    Dim a, dic As Object, x, myTxt As String, e, myMax As Long, myMin As Long, n As Long
    myTxt = InputBox("SiamSites - Niche Keyword Finder") 'change to suit
    If Len(myTxt) = 0 Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    myMin = UBound(Split(myTxt)) + 1
    With Sheets("AllKWs") 'change to suit
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
    End With
    ReDim b(1 To UBound(a, 1), 1 To 18)
    For Each e In a
        If InStr(1, e, myTxt, 1) > 0 Then
            x = UBound(Split(e)) + 1
            If Not dic.exists(x) Then dic.Add x, 0
            b(dic(x) + 1, x) = e: dic(x) = dic(x) + 1
            myMax = WorksheetFunction.Max(myMax, x)
        End If
    Next
    Erase a
    If x = 0 Then MsgBox "No match": Exit Sub
    ReDim Preserve b(1 To UBound(a, 1), 1 To myMax)
    maxR = WorksheetFunction.Max(dic.items)
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Multi Keywords").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Sheets.Add.Name = "Multi Keywords"
    With Sheets("Multi Keywords").Range("a1")
         For i = 1 To UBound(b, 2)
              If dic.exists(i) Then
                   .Offset(, n).Value = "The actual # of " & myMin & " word appearances"
                   .Offset(1, n).Value = "Total : " & dic(i)
                   .Offset(1, n + 1).Resize(myMax).Value = _
                                WorksheetFunction.Index(b, 0, i)
                   n = n + 2
               End If
         Next
    End With
End Sub

As a note, as to this line of code;

ReDim b(1 To UBound(a, 1), 1 To 100)

it now has become this if I've understood correctly

    ReDim b(1 To UBound(a, 1), 1 To 18)

As the rows in my "Multi Keywords" sheet are from A-R which is 18 Rows of Data.? I think this is what you meant to change from the number 100 to the correct row count for results.
When I tried to Run this Krishnakumar I got an error saying
"Run-time error '9'
Subscript out of range.
I clicked on debug and this line of code was highlighted in yellow;

 ReDim Preserve b(1 To UBound(a, 1), 1 To myMax)

Just as a note, by pure chance I hovered my mouse over the "myMax" piece of code and it said "myMax=15". I dn't know if this has any signifigance, but I just thought I'd mention it.

So, some error somewhere. I haven't a clue. I did try a couple of variations in the code, just inserting the lines slightly differently incase I misunderstood the instructions.
So, I hope the above code is correct Krishnakumar to how you explained the changes.
No clue as this is all above me why it came up with an error.

OK. Onto Jindons latest code posted.

this is the code exactly as I've ran it, (changed 20 to 18 and words "Multi KeyWords" to "Multi Keywords" (Don't know if this makes a difference but here is exactly how it now looks.

Sub NicheKeywordFinder2()
    Dim a, dic As Object, x, myTxt As String, e, myMax As Long, myMin As Long, n As Long
    myTxt = InputBox("SiamSites - Niche Keyword Finder") 'change to suit
    If Len(myTxt) = 0 Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    ReDim b(1 To Rows.Count, 1 To 18) '<- here
    myMin = UBound(Split(myTxt)) + 1
    With Sheets("AllKWs") 'change to suit
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
    End With
    For Each e In a
        If InStr(1, e, myTxt, 1) > 0 Then
            x = UBound(Split(e)) + 1
            If Not dic.exists(x) Then dic.Add x, 0
            b(dic(x) + 1, x) = e: dic(x) = dic(x) + 1
            myMax = WorksheetFunction.Max(myMax, x)
        End If
    Next
    Erase a
    If x = 0 Then MsgBox "No match": Exit Sub
    ReDim Preserve b(1 To UBound(a, 1), 1 To myMax)
    maxR = WorksheetFunction.Max(dic.items) '<- here
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Multi Keywords").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Sheets.Add.Name = "Multi Keywords"
    With Sheets("Multi Keywords").Range("a1")
         For i = 1 To UBound(b, 2)
              If dic.exists(i) Then
                   .Offset(, n).Value = "The actual # of " & myMin & " word appearances"
                   .Offset(1, n).Value = "Total : " & dic(i)
                   .Offset(1, n + 1).Resize(myMax).Value = _
                                WorksheetFunction.Index(b, 0, i)
                   n = n + 2
               End If
         Next
    End With
End Sub

Unfortunately I have an error here also
It says
"Run-time error'9'
Subscript out of range
I've clicked debug and the same line of code is highlighted yellow

ReDim Preserve b(1 To UBound(a, 1), 1 To myMax)

So, this is the problem line of code in both variations it seems.
Hope you can figure this out.
All above me.
Many thanks to you both though.
All the best
John Caines

 

[jindon]

try

Sub NicheKeywordFinder2()
    Dim a, dic As Object, x, myTxt As String, e, myMax As Long, myMin As Long, n As Long
    myTxt = InputBox("HuaHinCarRental - Niche Keyword Finder") 'change to suit
    If Len(myTxt) = 0 Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    myMin = UBound(Split(myTxt)) + 1
    With Sheets("All KWs") 'change to suit
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
    End With
    ReDim b(1 To UBound(a,1), 1 To 20)
    For Each e In a
        If InStr(1, e, myTxt,1)>0 Then
            x = UBound(Split(e)) + 1
            If Not dic.exists(x) Then dic.add x, 0
            b(dic(x)+1, x) = e : dic(x) = dic(x) + 1
            myMax = WorksheetFunction.Max(myMax, x)
        End If
    Next
    Erase a
    If x = 0 Then MsgBox "No match" : Exit Sub
    ReDim Preserve b(1 To UBound(a,1), 1 To myMax)
    maxR = WorksheetFunction.Max(dic.items) '<- here
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Multi KeyWords").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Sheets.Add.Name = "Multi KeyWords"
    With Sheets("Multi KeyWords").Range("a1")
         For i = 1 To UBound(b,2)
              If dic.exists(i) Then
                   .Offset(,n).Value = "The actual # of " & myMin & " word appearances"
                   .Offset(1,n).Value = "Total : " & dic(i)
                   .Offset(1,n+1).Resize(myMax).Value = _
                                WorksheetFunction.Index(b, 0, i)
                   n = n + 2
               End If
         Next
    End With
End Sub

 

[John Caines]

error again im afraid

Sorry Jindon, still got an error,
I tried inserting your code exactly and had this error,
==================================
"Run-time error '9':
Subscript out of range"
==================================
I clicked debug and this line of code was highlighed in yellow

 ReDim Preserve b(1 To UBound(a, 1), 1 To myMax)

2 questions though Jindon.
Do I need to change this line of code;

 ReDim b(1 To UBound(a, 1), 1 To 20)

to this line of code;

  ReDim b(1 To UBound(a, 1), 1 To 18)

As I have 18 columns of data to be returned. I think from part of a
revious post I have to change this???
If you can advise please,

Also this line of code

 maxR = WorksheetFunction.Max(dic.items) '<- here

Do I have to change anything here Jindon?? as I notice the "here" word?
I've just looked on the nett about the term "WorksheetFunction.Max",, and
see after it you usually put a range of data in?? I don't really know what
I'm talking about really,, but if something does need to be entered if
you can just advise.
As a note, the data I'm trying this macro on is in my "AllKWs" sheet
running from A3-A33288

1 other quick point, just to clarify.
All the data that does get returned in the "Multi Keywords" sheet is
from Row 3 downwards (Except for total amounts in Row 2.

I only mention this as I see in the code "a1" in quite a few places.
Again, I don't have a clue about this really, but just thought I'd mention it.

Many thanks again Jindon
Sorry I can't help
Above me all this
Many Thanks
John Caines

 

[Krishnakumar]

I think jindon is offline. Give it a try

Sub NicheKeywordFinder2()
    Dim a, dic As Object, x, myTxt As String, e, myMax As Long, myMin As Long, n As Long
    myTxt = InputBox("HuaHinCarRental - Niche Keyword Finder") 'change to suit
    If Len(myTxt) = 0 Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    myMin = UBound(Split(myTxt)) + 1
    With Sheets("All KWs") 'change to suit
        a = .Range("a3", .Range("a" & Rows.Count).End(xlUp)).Value
    End With
    ReDim b(1 To UBound(a, 1), 1 To 20)
    For Each e In a
        If InStr(1, e, myTxt, 1) > 0 Then
            x = UBound(Split(e)) + 1
            If Not dic.exists(x) Then dic.Add x, 0
            b(dic(x) + 1, x) = e: dic(x) = dic(x) + 1
            myMax = WorksheetFunction.Max(myMax, x)
        End If
    Next
    Erase a
    If x = 0 Then MsgBox "No match": Exit Sub
    ReDim Preserve b(1 To UBound(b, 1), 1 To myMax) 'altered here
    maxR = WorksheetFunction.Max(dic.items) '<- here
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Multi KeyWords").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Sheets.Add.Name = "Multi KeyWords"
    With Sheets("Multi KeyWords").Range("a1")
         For i = 1 To UBound(b, 2)
              If dic.exists(i) Then
                   .Offset(, n).Value = "The actual # of " & myMin & " word appearances"
                   .Offset(1, n).Value = "Total : " & dic(i)
                   .Offset(1, n + 1).Resize(myMax).Value = _
                                WorksheetFunction.Index(b, 0, i)
                   n = n + 2
               End If
         Next
    End With
End Sub

 

[John Caines]

It's working Getting close now

Many Thanks Krishnakumar.
It's working
It's given me some results!!
Definately getting there
Brilliant

Kind of hard to explain, but here goes.
I think I'll try by capturing a screen shot of what it has returned
so you can visually see the results

Copy of Advanced Keyword Sheet.xlsm
	A	B	C	D	E	F	G	H	I
1	The actual # of 2 word appearances		The actual # of 2 word appearances		The actual # of 2 word appearances		The actual # of 2 word appearances		The actual # of 2 word appearances
2	Total : 2	real estate	Total : 1032	l real estate	Total : 3926	real estate i n	Total : 1601	real estate in n c	Total : 305
3		nreal estate		n real estate		dc dc real estate		real estate in u s
4				s real estate		real estate in ca		r and a real estate
5				al real estate		real estate in dc		era real estate in nh
6				an real estate		real estate in ma		n fork ut real estate
7				az real estate		real estate in mi		ny and ct real estate
8				ca real estate		real estate in mo		real estate agent i n
9				co real estate		real estate in nc		real estate law in pa
10				ct real estate		real estate in ny		a m real estate center
11				dc real estate		real estate in ok		j s walker real estate
12				fl real estate		real estate in pa		n trail nc real estate
13				ga real estate		real estate in wi		real estate el paso tx
14				il real estate		real estate ni ny		real estate exam in ny
15				in real estate		az real estate mls		real estate in eden nc
16				la real estate		bay fl real estate		real estate in my area
Multi Keywords

I'll start to explain what I think needs amending
I already have the sheet called "Multi Keywords" formatted nicely. It has alternating row colours, blue filled headings and written heading columns. I captured a screenshot of it earlier in this post.

Rather than the macro returning a new sheet, can it imput the data into the sheet I already have?
Or, if this is not possible, can it create the sheet in the format I already have?

The column headings it's returning now all say the same "The actual# of 2 word appearances"
It says this on each column heading. Actually I think the text is a bit long.
In my earlier screen shot of my formatted "Multi Keyword" sheet it read as follows in the headings. (By the way, "Occur" is just short for "Occurances", I kept this short as these columns will only return a number value and as such would or can be quite a narrow column, so the sheet fits more info in)

A1= "Occur"
B1= "2 Word Phrases"
C1= "Occur"
D1= "3 Word Phrases"
E1= "Occur"
F1= "4 Word Phrases"
G1= "Occur"
H1= "5 Word Phrases"
I1= "Occur"
J1= "6 Word Phrases"
K1= "Occur"
L1= "7 Word Phrases"
M1= "Occur"
N1= "8 Word Phrases"
O1= "Occur"
P1= "9 Word Phrases"
Q1= "Occur"
R1= "10 Word Phrases"

(All without Quotation Marks).
Now it bullet point fashion;

1.It's filling in the Totals it seems ok in the "Occur" Columns
2. Data returned for the "No of Word Phrases" is starting 1 cell too high. All results of phrases should start from Row 3 not 2
3. Next to each keyword phrase returned should be a number (The number of times it is found within the "AllKWs" list. I'll give an example now.
At the moment, in ColF the macro has returned the phrase "real estate in ca",, so this should be under the heading "4 Word Phrases".
There should be a number next to this in it's "Occur" Column.
The number would be the number of times "real estate in ca" is found throughout the whole sheet.
So, even if it was in a longer phrase, it would be another appearance.
It could be in a phrase like, "new real estate in ca for sale" this is a 7 word phrase, and as such would be in the 7 word phrases column. But because "real estate in ca" is within that 7 word phrase,, it is another occur of that 4 word phrase.

(And by the way the search I inputted into the search pop up box of the macro was for "real estate")
So, all the returned phrases related to the search term "real estate" come back in order of "Occurrance"
Also, in the cells B2,D2,F2,H2,J2,L2,N2,P2,R2 there is the word "Total:" if this can dynamically calculate the total Number of Phrases for it's respective column.


Also, how the sheet has returned the results in column widths. They are the wrong way around.
The narrow columns at present have the phrases in, (Which should be the wider Columns)
So, the sheet needs to start off with a Narrow column (ColA) not a wide Column.
It only needs to return up to "10 Word Phrases" that's up to Column R.
At the moment in this search it returned a 15 word phrases, so I guess it's returning everything it finds in the list.
Only needs to be a maximum of 10 Word Phrases


I think that's about it for now
It really is getting there though for sure.
Many Thanks again.
I hope all the above makes sense also.
Many Thanks
John Caines