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]

just try

=CountIf(AllKWs!A:A,"*"&B3&"*")

and see if it returns correct value

 

[John Caines]

count if

I take it you mean just open a new sheet.
Copy;
=CountIf(AllKWs!A:A,"*"&B3&"*")
into cell A1 of new sheet.

Yes it returns a value of 33,285.

My AllKWs sheet starts from row 3. and runs down to 33288.
So I take it this is correct for what you asked Jindon??

Many Thanks
John Caines

 

[jindon]

Can you just try this?

Sub NicheKeywordFinder2()
    Dim a, dic As Object, x, myTxt As String, e, myMax As Long
    Dim myMin As Long, n As Long, myRange As String
    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
        With .Range("a3", .Range("a" & Rows.Count).End(xlUp))
             a = .Value
             myRange = "'All KWs'!" & .Address(1,1,xlR1C1)
    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).Resize(myMax).formulaR1C1 = _
                    "=if(rc[1]<>"""",countif(" & myRange & ",""*""&rc[1]&""*""),"""")"
                   .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

Sorry Jindon,
Tried to run the macro, got an error.

The

End Sub

Was highlighted in grey.
And the starting phrase

Sub NicheKeywordFinder2()

Is in yellow.

Any ideas?
Many Thanks
John Caines

 

[jindon]

Strange, have you replaced the code with existing code?

otherwise, you need to change the sub name like
NickeKeywordFinder3 or something

 

[John Caines]

just tried something

Hello Jindon,
Thought I'd try adding
[End With]
again at the end of your formula.
It actually didn't didn't error then to start with.
The pop up box appeared.
I entered the word "Homes" into it.
I clicked enter

I then got an error which said;
=====================
"Run-time error '1004'
Application-defined or object-defined error
=====================

I clicked debug and these 2 lines of code were highlighted yellow;

 .Offset(1, n).Resize(myMax).FormulaR1C1 = _
  "=if(rc[1]<>"""",countif(" & myRange & ",""*""&rc[1]""*""),"""")"

Hope you can work this out, I haven't a clue.

Many thanks again Jindon.
John Caines

 

[jindon]

Re: just tried something

can you change it to

 .Offset(1, n).Resize(myMax).FormulaR1C1 = _
  "=if(rc[1]<>"""",countif(" & myRange & ",""*""&rc[1]&""*""),"""")"

 

[John Caines]

It's getting very close Now Jindon

Jindon
Good news!!!!!!!!!!!!!
Got some results,,,, and its really getting close
I'll attach a screen shot, then I'll post my thoughts after.

But I think you can see yourself from the screenshot whats come back.
Main point to not;
It's returning results, Like 3 word phrases,260 in total,,,, but like the phrase "alabama manufactured homes" in F3,,, no results in E3 as to how many times that phrase appears in the sheet.

But brilliant though Jindon,
I think you're so close to cracking it.
Here's the screen capture anyway;

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

 

[jindon]

Right, can you change

    With Sheets("All KWs") 'change to suit
        With .Range("a3", .Range("a" & Rows.Count).End(xlUp))
             a = .Value
             myRange = "'All KWs'!" & .Address(1,1,xlR1C1)  '<- here
    End With

 

[John Caines]

just a quick few notes

Hello Jindon,
Just a quick few points about screen capture.

ColA has returned some results. Brilliant!
If possible, the phrases should be returned in order of Number of appearances so,, from the screenshot Of ColA and B.

Should have looked something like;
=====================
A B
= ==
Occur 1 Word Phrases
Total:1,259 Total:17
1240 homes
5 homesforsale
3 fish4homes
1 atlantahomesforrent
1 eharmonhomes
etc etc etc etc etc etc
=====================

Also notice all of returned word phrases are coming back on Row 2 instead of row 3.

Then, all the other columns the same really. They all at the moment show the Number of different Phrase occurrences, (But these need to be moved 1 Col over to the right)
So, actually in Cell A1 "Occur # of 1 word Phrases" should be in cell B1
Cell A1 should contain the word "Occur" and this will total the total Number of Occurrences of all the 1 word phrases combined.


That's about it.
Sorry, 1 last thing.
All the results stop on Row 16?

Many Thanks Jindon.
It's definitely getting there.
John Caines