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]

Thanks again, Kris

John
1) Learn to record a macro for yourself regarding Format the sheet.
2) try

Sub NicheKeywordFinder2()
    Dim a, dic As Object, x, myTxt As String, e, myMax As Long, myMin As Long, n As Long, y, z
    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
    y = dic.Keys : z = dic.Items
    With Sheets("Sheet1").Range("a1")
         For i = 0 To UBound(y)
              .Offset(, n).Value = "The actual # of " & y(i) & " word appearances"
              .Offset(1, n).Value = "Total : " & z(i)
              .Offset(1, n + 1).Resize(myMax).Value = _
                                WorksheetFunction.Index(b, 0, i)
              n = n + 2
         Next
    End With
End Sub

 

[John Caines]

Many thanks Guys - I've tried formatting-Don't laugh

Many thanks Jindon for your reply.
Still a few problems I'm afraid

But first, you mentioned about me having a go at formatting the sheet myself.
As you know, I know practically nothing about VB.
But,, you are right, only 1 way to learn ,, try
So I have.

Please don't laugh at the following code.
As I type, I'm trying to read about "recording a macro and formatting"
Man, this is difficult.
I know to you Jindon, writing this kind of code is probably as easy as just eating "Sushi"
but really,, this is all really difficult for me.
Anyway,, I've had a go and I can't get it to work
Again, please don't laugh at what I wrote.
I've looked at some of your previous macros you've written, and how you inserted formatting etc,
and tried my best to amend/insert etc in what I felt was the correct places.
It is probably wrong,,, but I have tried.
After this post I will look a bit more into the help files and see if I can just get it working.
Anyway, here is my attempt;

Sub NicheKeywordFinder2()
    Dim a, dic As Object, x, myTxt As String, e, myMax As Long, myMin As Long, n As Long, y, z
    myTxt = InputBox("SiamSites - Niche Keyword Finder")
    If Len(myTxt) = 0 Then Exit Sub
    Set dic = CreateObject("Scripting.Dictionary")
    myMin = UBound(Split(myTxt)) + 1
    With Sheets("AllKWs") 'change to suit
     With .Cells.Font
                .Name = "Tahoma"
            .Size = 9 '
             With .Rows(1)
                    .RowHeight = 21
                    .Font.Size = 11
            .Font.Bold = True
              With .Rows(2)
                     .RowHeight = 11.25
                     .Font.Size = 9
            .Font.Bold = True
        a = .Range("a3", .Range("a" & Rows.Count).End(xlUp)).Value
    End With
     With .Range("a1")
            With .Resize(, 18)
            .Value = Array("Occur", "2 Word Phrases", "Occur", "3 Word Phrases", "Occur", "4 Word Phrases", "Occur", "5 Word Phrases", "Occur", "6 Word Phrases", "Occur", "7 Word Phrases", "Occur", "8 Word Phrases", "Occur", "9 Word Phrases", "Occur", "10 Word Phrases")
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .Interior.Color = RGB(51, 102, 255)
                        With .Offset(, -2).Resize(, 7)
                                    .FormatConditions.Add Type:=xlExpression, Formula1:="=mod(row(),2)=0"
                    .FormatConditions(1).Interior.Color = RGB(240, 240, 240)
            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(b, 1), 1 To myMax) 'altered here
    maxR = WorksheetFunction.Max(dic.Items) '<- here
    y = dic.Keys: z = dic.Items
    With Sheets("Multi Keywords").Range("a1")
         For i = 0 To UBound(y)
              .Offset(, n).Value = "Occur " & y(i) & " Word Phrases"
              .Offset(1, n).Value = "Total : " & z(i)
              .Offset(1, n + 1).Resize(myMax).Value = _
                                WorksheetFunction.Index(b, 0, i)
              n = n + 2
         Next
    End With
End With
        .Range("a:r").EntireColumn.AutoFit
        .Select
        .Range("a3").Select
    End With
    ActiveWindow.FreezePanes = True
    
End Sub

Are you laughing yet??
Several points to mention about what I wrote, and certain lines of code.
I inserted these lines;

 With .Cells.Font
                .Name = "Tahoma"
            .Size = 9 '
             With .Rows(1)
                    .RowHeight = 21
                    .Font.Size = 11
            .Font.Bold = True
              With .Rows(2)
                     .RowHeight = 11.25
                     .Font.Size = 9
            .Font.Bold = True

I think this makes the whole of the returned sheet "Multi Keywords" sheet font "Tahoma"??
With a size 9 font??
Also I think it also conditions the row heights of rows 1 and 2 and makes them "Bold"????
=============
Can you confirm if I've done this correctly also Jindon? I hope it's right
=============
Next, I inserted these lines of code;

With .Range("a1")
            With .Resize(, 18)
            .Value = Array("Occur", "2 Word Phrases", "Occur", "3 Word Phrases", "Occur",
            "4 Word Phrases", "Occur", "5 Word Phrases", "Occur", "6 Word Phrases", "Occur",
            "7 Word Phrases", "Occur", "8 Word Phrases", "Occur", "9 Word Phrases", "Occur",
            "10 Word Phrases")
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .Interior.Color = RGB(51, 102, 255)
                        With .Offset(, -2).Resize(, 7)
                                    .FormatConditions.Add Type:=xlExpression, Formula1:="=mod(row(),2)=0"
                    .FormatConditions(1).Interior.Color = RGB(240, 240, 240)

What I've tried to do looking at some of the other code you have written for other macros
is as follows.
1.Make all of Row 1 auto insert the correct headings (IE "Occur" and "Word Phrases" etc)
2.Give Row 1 a fill colour (RGB 51,102,255----A nice blue)
3.Also give all the returned rows of data an alternating row colour
4. I'm not too sure on the line of code that says

 With .Resize(, 18)

I think this means I have now made all the data that gets returned resize for the 18 Columns?????
=============
Have I done this part right also please Jindon???? Really not sure
=============
At the bottom of the code I've inserted the following;

        Next
    End With
End With
        .Range("a:r").EntireColumn.AutoFit
        .Select
        .Range("a3").Select
    End With
    ActiveWindow.FreezePanes = True
    
End Sub

I think this is so all returned results auto fit column widths?
Also, it automatically freezes the pane from Row 3????
===========
Is this bit correct also Jindon???
===========
As you can see, I've tried to make several changes.
Not sure if any are correct. I think most of the lines possibly are,
but my problem is knowing where to insert them also.
Ok,Next;
Just need some confirmation or info on some of your lines I've
altered please Jindon. These are as follows;

In 1 of your lines of code Jindon it said

.Offset(, n).Value = "The actual # of " & y(i) & " word appearances"

I've changed this to

.Offset(, n).Value = "Occur " & y(i) & " Word Phrases"

This matches the screen captureI posted on page 1 of this post, and means
the col widths for "Occurrances" will be much narrower, as the heading
""The actual # of " & y(i)" is now just "Occur"

I'm still not too sure why these 2 lines of code have "alter here" and
"<-here" beside them in your code;

 ReDim Preserve b(1 To UBound(b, 1), 1 To myMax) 'altered here
    maxR = WorksheetFunction.Max(dic.Items) '<- here

I've just left them as is, but if I do neeed to change them to something else,,
can you advise me please, as I'm not sure actually what they are

You have 1 line of code which is

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

Is this relating to number of columns of data to be returned in the "Multi Keyword" sheet?
I've changed it to

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

============
Can you confirm if I was right to have done this change please Jindon?
==============
Finally 1 line of code was

With Sheets("Sheet1").Range("a1")

Which I've changed to

With Sheets("Multi Keywords").Range("a1")

As you can see Jindon, I have tried to format this code for the returned
sheet "Multi Keywords". But when I've gone to run it the last line of code

End Sub

Is highlighted as grey, and the first line of code

Sub NicheKeywordFinder2()

Is in yellow.#So it's got an error somewhere

I hope you don't laugh too much at the above attempt.
I did try
Again, I'll try and look more into the help file, and see if I can just
even get this to run.

==============================================
OK. On to your code Jindon, and the data it returned.
Firstly though, here is the exact code as I altered just a few lines in it;

Sub NicheKeywordFinder2()
    Dim a, dic As Object, x, myTxt As String, e, myMax As Long, myMin As Long, n As Long, y, z
    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("a3", .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(b, 1), 1 To myMax) 'altered here
    maxR = WorksheetFunction.Max(dic.Items) '<- here
    y = dic.Keys: z = dic.Items
    With Sheets("Multi Keywords").Range("a1")
         For i = 0 To UBound(y)
              .Offset(, n).Value = "Occur " & y(i) & " Word Phrases"
              .Offset(1, n).Value = "Total : " & z(i)
              .Offset(1, n + 1).Resize(myMax).Value = _
                                WorksheetFunction.Index(b, 0, i)
              n = n + 2
         Next
    End With
End Sub

I only changed a few words like in this line

With Sheets("Sheet1").Range("a1")

I altered to this line of code

With Sheets("Multi Keywords").Range("a1")

The search wrd I used in this macro was for the word "homes"
Here is a screen capture of what came back

My Keyword Sort Sheet.xlsm
	A	B	C	D	E	F	G	H
1	Occur2WordPhrases		Occur9WordPhrases		Occur3WordPhrases		Occur4WordPhrases
2	Total:183	atlantahomesforrent	Total:2	atlantahomesforrent	Total:260	2ndhomes	Total:291	acliforniarentalhomes
3		eharmonhomes		eharmonhomes		99homes		alabamamanufacturedhomes
4		escapehomes		escapehomes		ablihomestay		altantarentalhomes
5		fish4homes		fish4homes		acrdinalhomes		amazingvacationhomes
6		fsih4homes		fsih4homes		adllastownhomes		ancientromanhomes
7		hearmonhomes		hearmonhomes		ahrmonhomes		apartmenttownhomeshouston
8		homes		homes		arizonahomes		arizonarentalhomes
9		homes4rent		homes4rent		arubahomes		asalnhomesllc
10		homesaerch		homesaerch		ashevillehomes		ashevilleluxuryhomes
11		homesearch		homesearch		aslanhomescom		aslanhomesllc
12		homeseller		homeseller		atlantahomes		atlantaluxuryhomes
13		homesforsale		homesforsale		atlantatownhomes		atlantarentalhomes
14		homestead		homestead		atlatnahomes		austinareahomes
15		homestore		homestore		augustahomes		bergencountyhomes
16		homestudy		homestudy		austinhomes		bigskyhomes
Multi Keywords

 

[jindon]

Good try.
You can never learn if you don't try.
Actually the code should look like this apart from formatting...
I'll look at the formatting part later...

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
    With Sheets("Sheet1").Range("a1")
         For i = 1 To UBound(b,2)
              If dic.exists(i) Then
                   .Offset(, n).Value = "The actual # of " & i & " 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]

Many Thanks for reply Jindon.

Hello Jindon,
Many thanks for your swift reply.

I will read it now.

Firstly though, my post just before your last post(1 with screen capture in)

there is actually more text to that post.
It should have come out after the screen capture.
I've tried several times to re edit it.
Just comes out the same.

So, here now is the ending part of my previous post;
=========================================
As you can see, it's getting there
Main points I can see,
1.Cell A1 then alternating (IE C1,E1 etc) should only have the word "Occur" in it

2. Cells B1, then alternating (IE D1,F1,H1 etc) Should have its relevant "Word Phrases" heading,, IE "2 Word Phrases" or "3 Word Phrases" for the 3 word phrases column.
I have tried looking at your code Jindon and literally just trying to change or take out an odd letter or character, but I couldn't do it
The line I'm guessing the problem is on could be

.Offset(, n).Value = "Occur " & y(i) & " Word Phrases"

Is it this line of code that's causing this error Jindon???
It's only a pure guess of mine, but that's the line of code that relates to this area I think?
Not sure

3. Data returned in Col B and D are the same (I think?) Really, looking at the screenshot, it seems maybe this is an error by me, as I have omitted a column saying "1 Word Phrases". I think this could be part of the problem.
All returned data in Col B and D is 1 word data.
A column for which I don't have.
Col F is showing all 2 word data, which should be returned in Col D.


OK,, Sorry about this everyone.
I think I've made a mistake by leaving out a "1 Word Phrase" Column (Which should be in Col A not the "2 Word Phrases" which is already there).
My mistake.

I'm going to post what I've written so far, and try and make the adjustments in my code,
as to just inserting another Column for all 1 word phrases, which will mean I have 20 Rows of data and not 18.

I hope all the above makes sense.
Many thanks everyone on this.
And Jindon, please try not to laugh too much at my formatting attempt
in the code
I did try.
Many Thanks
John Caines
====================================

That's the end of my previous post Jindon.
I'll now read your reply , as I haven't read it yet.
Many Thanks
John Caines

 

[Norie]

John

I'm going to ask once again, sorry.

But what is your ultimate goal here?

You seem intent on using code but I'm sure a lot of what you want to do could be solved by using formulas and/or other built-in Excel functionality. eg filters, subtotals etc

 

[John Caines]

reply

First to answer you Norie.
Actually, I think what I'm asking for is quite complicated.
I no coder Norie. Simple as that.
But the information I'd love to be returned at the click of a button must
require a macro surely?

I did my best to explain at the start of this post what I'd love this macro to be able to do.
Usually, when I try to explain something that's quite complicated,
Something gets lost in my translation
Also, I think what I'm asking for is very complicated and isn't a
simple filtering job.

The best way for me now to further explain as the macro is now running
is to show a screen capture of what I'd like the results to come back like, and what is coming back at the moment.

Then, you can see exactly what this macro is all about.
So, for the search term "homes", looking at 33,288 rows of data in my "AllKWs" list.
Here is a screen capture of the results and how they are being returned
at the moment from the last posted code of Jindons, which for clarity I'll post again now;

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("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
    With Sheets("Multi Keywords").Range("a1")
         For i = 1 To UBound(b, 2)
              If dic.exists(i) Then
                   .Offset(, n).Value = "The actual # of " & i & " 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

(Then I'll make another post with a screen capture as to how I think they should be returning)

Copy of My Keyword Sort Sheet For Joseph Was.xlsm
	A	B	C	D	E	F	G	H
1	Theactual#of1wordappearances		Theactual#of2wordappearances		Theactual#of3wordappearances		Theactual#of4wordappearances
2	Total:17	atlantahomesforrent	Total:183	2ndhomes	Total:260	acliforniarentalhomes	Total:291	albertahomesforrent
3		eharmonhomes		99homes		alabamamanufacturedhomes		albertahomesforrent
4		escapehomes		ablihomestay		altantarentalhomes		arizonahomesforrent
5		fish4homes		acrdinalhomes		amazingvacationhomes		arizonahomesforsale
6		fsih4homes		adllastownhomes		ancientromanhomes		atlantahomesforrent
7		hearmonhomes		ahrmonhomes		apartmenttownhomeshouston		atlantahomesforsale
8		homes		arizonahomes		arizonarentalhomes		atlantahomesotrent
9		homes4rent		arubahomes		asalnhomesllc		atlantahomestorent
10		homesaerch		ashevillehomes		ashevilleluxuryhomes		atlantaluxurygolfhomes
11		homesearch		aslanhomescom		aslanhomesllc		austinhomesforlease
12		homeseller		atlantahomes		atlantaluxuryhomes		beachhomesforsale
13		homesforsale		atlantatownhomes		atlantarentalhomes		beavertonhomesforsale
14		homestead		atlatnahomes		austinareahomes		bozemanhomesforsale
15		homestore		augustahomes		bergencountyhomes		brooklynhomesforsale
16		homestudy		austinhomes		bigskyhomes		buyandsellhomes
Multi Keywords

 

[John Caines]

How ultimately they should be returned

Copy of Advanced Keyword Sheet.xlsm
	A	B	C	D	E	F	G	H
1	Occur	1WordPhrases	Occur	2WordPhrases	Occur:	3WordPhrases	Occur	4WordPhrases
2	Total:32,979	Total:1,234	Total:16,391	Total:989	Total:5283	Total:756	Total:5132	Total:345
3	23,978	homes	4,876	2ndhomes	1,234	bigskyhomes	1123	buyandsellhomes
4	1,345	homes4rent	3,456	99homes	976	atlantaluxuryhomes	1109	beachhomesforsale
5	1,213	homesearch	2,241	ablihomestay	876	atlantarentalhomes	867	arizonahomesforsale
6	1,123	homesaerch	1,678	acrdinalhomes	567	amazingvacationhomes	499	arizonahomesforrent
7	989	fish4homes	876	adllastownhomes	453	alabamamanufacturedhomes	434	atlantahomesotrent
8	879	escapehomes	768	ahrmonhomes	345	arizonarentalhomes	340	atlantahomestorent
9	786	homesforsale	657	arizonahomes	299	ancientromanhomes	290	atlantahomesforsale
10	657	homeseller	546	arubahomes	107	altantarentalhomes	105	atlantahomesforrent
11	567	homestore	435	ashevillehomes	87	austinareahomes	81	albertahomesforrent
12	345	homestudy	267	aslanhomescom	67	bergencountyhomes	65	brooklynhomesforsale
13	340	homestead	167	atlantahomes	60	ashevilleluxuryhomes	59	beavertonhomesforsale
14	319	hearmonhomes	157	atlantatownhomes	59	apartmenttownhomeshouston	50	austinhomesforlease
15	209	fsish4homes	123	atlatnahomes	55	acliforniarentalhomes	49	atlantaluxurygolfhomes
16	106	eharmonhomes	77	augustahomes	50	asalnhomesllc	34	bozemanhomesforsale
17	123	atlantahomesforrent	67	austinhomes	48	aslanhomesllc	27	albertahomesforrent
Multi Keywords

 

[John Caines]

summary

Just to summerise the above screenshot of how the results should come back.

The phrases for example "2 Word Phrases" are returned not on alphabetical order but by number of appearances throughout the whole sheet.
So, in ColD,, the 2 word Phrase "2nd Homes" has appeared 4,876 times throughout the whole sheet.
In other words, it could even have occurred in a 7 or 8 or 9 word phrase,
for example
"best 2nd homes in new york for sale" is an 8 word phrase, but this has another occurrance of "2nd homes",, so it is added to the total Number of Occurrances for "2nd homes" In ColC (Cell C3).

Then all in Row 2 are the totals.
So, again for example in Col D (Cell D2) the total is "989". This means there are 989 2 word phrases throughout the "All KWs" list of 33,288 rows of phrases.
So, I hope this makes sense everyone. I hope this clarifies things Norie.

As I stated at the start of this post, this is more complicated than it seems.
Many thanks to Krish, and Jindon for there help so far on this.
It's really getting there.
Many Thanks
John Caines

 

[jindon]

I don't understand the numbers in Col.A/C/E/G....

 

[John Caines]

Explaination for sheet

Hello Jindon,
Yes, it is a bit confusing, probably due to column B .

OK, I will try and explain this as best I can in a kind of bullet point fashion.
Remember this sheet has returned all results for the search term "Homes".

ColA.
Col A contains the amount of times these 1 word phrases appear throughout all the rows of data in my "AllKWs" list.
(I've made up the numbers purely for this example).
They relate to all the 1 word phrases in ColB.
ColB is actually all 1 word phrases. As my "AllKWs" list contains mispelled words, and as such, some words do not
have spaces in between. So all that you can see in ColB are infact counted as being 1 word.
For example the 1 word "homesforsale" is actually as we all know 3 words,, but because there are no spaces between
the 3 words, it is a 1 word phrase.
ColA then lists how many times "homesforsale" is found within all my 30,000+ rows of data, and returns that figure.
ColA lists all the data by most amount of Occurrances first.
So, in this example, ColA for the 1 word term "Homesforsale" occurred in the 30,000+ rows of data 786 times.

ColC.
Lists all the Occurrances of 2 word phrases that contain the word "homes" throughout my "AllKWs" sheet.
So, in Cell D3, there is the 2 word phrase "2nd homes". This has been found 4,876 times throught all the rows
of data in my "AllKWs" sheet.
So, how has the 2 word phrase occurred 4,876 times. Well, it could have been in a 5,6,7,8,9 etc word phrase.
For example, "New 2nd homes for sale" is a 5 word phrase. But it has another occurrance of "2nd homes" within it.
So, this occurrance is added to its number of Occurrances in ColC.

ColE.
The term "big sky homes" has appeared in my "AllKWs" sheet 1,234 times. It has occurred the most out of all 3 word phrases.
Again, as an example, 1 of its 1,234 occurrances could have been in a phrase like;
"Best big sky homes for rent in florida". This is a 8 word phrase, but has the 3 word phrase "big sky homes" within it.
So, this is added to it's total Number of occurrances in ColE.

And so on, continuing up to 10 word phrases.

So, to sum up.
In the macro, I type in any search term.
For the above example "homes".
The macro is actually finding every occurrance with the word "homes" in.
It is then filtering them in either 1,2,3,4,5,6,7,8,9,10 word phrases. (So it is basically looking at words either side
of the word "Homes" and putting all the phrases in their respective Word Count Columns).
It is returning the results by number of appearances. With the most first.

The "totals" are exactly that.
In ColA Total, this is all the Number of Occurrances for 1 word phrases added together.
In ColB Total, this is the total amount of all 1 word phrases found.
These Totals are carried on throughout the sheet right up to 10 word phrases

I hope this makes sense Jindon.
As I said at the start of this post,, this is a very complicated macro I think
Many Thanks
John Caines