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

 

[John Caines]

Good news, working 100%

Hello Jindon,
Sorry for the confusion
Strange, I've rebooted the PC today, I've opened excel,
Ran your macro
When I ran your macro, this is the data that is being returned.
It's perfect! All the data and No. of Occurrances have been returned perfectly.
Maybe it's me, how I've been trying and retrying in VB different versions regarding the formatting.
So, as it stands, the data being returned is perfect, it's just the formatting now that I've tried to impliment, but I've not done this correctly.
here's a screen shot exactly how it looks.

My Keyword Sort Sheet1.xlsm
	A	B	C	D	E	F	G	H
1		No#of1WordPhrases		No#of2WordPhrases		No#of3WordPhrases		No#of4WordPhrases
2		Total:10		Total:111		Total:105		Total:121
3	529	condo	18	condorental	103	condoforrent	5	beachcondoforrent
4	129	condos	12	rentcondo	17	condosforsale	2	condoestatemiamireal
5	54	condominium	8	bransoncondo	16	condosforrent	2	condoforrenttampa
6	33	condominiums	6	condorentals	7	condominiumsforsale	2	floridacondoforrent
7	4	condomiinum	6	vacationcondo	5	condoforsale	2	georgiacondosforrent
8	2	condominums	5	hawaiiancondo	5	rentacondo	2	lasvegasluxurycondo
9	1	condominio	4	bangkokcondo	3	condosinhawaii	1	39condoernts
10	1	condominuims	4	chicagocondo	3	highrisecondos	1	39condorents
11	1	condomniiums	4	condorenatl	3	lasvegascondo	1	affordablemauicondoaccommodations
12	1	condotel	4	condos	2	atlantageorgiacondos	1	affordablemauicondoaccommodations
13			4	georgiacondos	2	bransoncondorental	1	arizonacondosforrent
14			3	condobangkok	2	hawaiiancondorental	1	atlanatcondopropertymanager
MultiResults

I've tried formatting the sheet "Multi Keywords" Jindon
(See my previous post) but I must be just putting in the formatting either in the wrong places, or adding something which is making it not run correctly.

These are the lines of code I'm trying to put in,
I'm not 100% sure they are correct, but hopefully they are.

1.Timer

    sTime = Timer
MsgBox "Time Elapsed: " & Format(Timer - sTime, "#,##0.000") & " sec"

2.Formatting the whole sheet "MultiKeywords"

With .Cells.Font
            .Name = "Tahoma"
            .Size = 9 '<- Font size for entire sheet here

3.Formatting Rows 1 and 2

With .Rows(1)
            .RowHeight = 21
            .Font.Size = 11
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Interior.Color = RGB(51, 102, 255)

            With .Rows(2)
            .RowHeight = 15
            .Font.Size = 10
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter

4.Conditional Formatting; Trying to get the whole sheet alternate row colours, like a slight shade of grey, with the borders a grey colour also.
I think the code is like this Jindon;

.FormatConditions.Add Type:=xlExpression,
 Formula1:="=mod(row(),2)=0"
.FormatConditions(1).Interior.Color = RGB(240, 240, 240)

That's it Jindon.
Seems simple enough?, For you it is I'm 100% certain
I tried for 6 hrs last night and still just couldn't quite get it.
When I seemed to get 1 bit right, I then tried adding something else, then it wouldn't work

Could you please just post how the macro would look with these formatting lines of code in Jindon please.

Just to make things 100% clear, here is exactly what code I have in excel now for "MultiKeywords" macro

Sub Multi_Keyword_Finder()
    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("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
        With .Range("a3", .Range("a" & Rows.Count).End(xlUp))
             a = .Value
             myRange = "'AllKWs'!" & .Address(1, 1, xlR1C1) '<- here
    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("MultiResults").Range("a1")
         For i = 1 To UBound(b, 2)
              If dic.exists(i) Then
                   .Offset(, n + 1).Value = "No # of " & i & " Word Phrases"
                   With .Offset(2, n).Resize(maxR)
                        .FormulaR1C1 = _
                         "=if(rc[1]<>"""",countif(" & myRange & ",""*""&rc[1]&""*""),"""")"
                         .Value = .Value
                   End With
                   .Offset(1, n + 1).Value = "Total : " & dic(i)
                   .Offset(2, n + 1).Resize(maxR).Value = _
                                WorksheetFunction.Index(b, 0, i)
                   With .Offset(2, n).Resize(maxR, 2)
                        .Sort key1:=.Cells(1, 1), order1:=xlDescending, Header:=xlNo
                        On Error Resume Next
                        .SpecialCells(4).Delete xlShiftUp
                        On Error GoTo 0
                   End With
                   n = n + 2
              End If
         Next
    End With
    End With
End Sub

I best not repost how I tried to insert the formatting into your code Jindon, as I don't want to confuse this.

But, on my previous post you can see how I inserted the code, and the macro just didn't run correctly, so Obviously I'd done something wrong.

Many thanks Jindon.
Seems it is working 100% now.
If you can just post what it would look like with the above formatting lines of code, as I just can't seem to do this right.

Many thanks agian
John Caines

 

[jindon]

Re: reply

OK
try

Sub Multi_Keyword_Finder()
    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("SiamSites - Niche Keyword Finder") 'change to suit
    If Len(myTxt) = 0 Then Exit Sub
    sTime = Timer
    Set dic = CreateObject("Scripting.Dictionary")
    myMin = UBound(Split(myTxt)) + 1
    With Sheets("AllKWs") 'change to suit
        With .Range("a3", .Range("a" & Rows.Count).End(xlUp))
             a = .Value
             myRange = "'AllKWs'!" & .Address(1, 1, xlR1C1) '<- here
    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("MultiResults")
        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
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Interior.Color = RGB(51, 102, 255)
        End With
        With .Rows(2)
                .RowHeight = 15
                .Font.Size = 10
                .Font.Bold = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
        End With
        With .Range("a1")
              For i = 1 To UBound(b, 2)
                  If dic.exists(i) Then
                       .Offset(, n + 1).Value = "No #  " & i & " Word Phrases"
                       With .Offset(2, n).Resize(maxR)
                            .FormulaR1C1 = _
                             "=if(rc[1]<>"""",countif(" & myRange & ",""*""&rc[1]&""*""),"""")"
                             .Value = .Value
                       End With
                       .Offset(1, n + 1).Value = "Total : " & dic(i)
                       .Offset(2, n + 1).Resize(maxR).Value = _
                                WorksheetFunction.Index(b, 0, i)
                       With .Offset(2, n).Resize(maxR, 2)
                            .Sort key1:=.Cells(1, 1), order1:=xlDescending, Header:=xlNo
                            On Error Resume Next
                            .SpecialCells(4).Delete xlShiftUp
                            On Error GoTo 0
                       End With
                       n = n + 2
                     End If
                Next
               With .CurrentRegion
                   .FormatConditions.Add Type:=xlExpression, Formula1:="=mod(row(),2)=0"
                   .FormatConditions(1).Interior.Color = RGB(240, 240, 240)
                   End With
         End With
    .Select
    .Range("a1").CurrentRegion.EntireColumn.AutoFit
    End With
    ActiveWindow.FreezePanes = True
    
    MsgBox "Time Elapsed: " & Format(Timer - sTime, "#,##0.000") & " sec"
    
End Sub

 

[John Caines]

100% Perfect

Absolutely perfect now Jindon

Running perfectly.
Truly brilliant.
I can see now how you've inserted the formatting now,, yes,, I can see it is different from everything I was trying last night.
Yes, I did try many ways last night, but obviously not the right way

I did have to add 1 small line of code in order for this to work Jindon.
Just before the last line of code that says;

End Sub

I had to add the line ;

End With

Not sure why, but it wouldn't run without me inserting that line.

This truly is a great macro Jindon.
I said at the very start of this post it would be a difficult 1.
Again,
Many thanks for all your help.
I appreciate it greatly
Many Thanks
John Caines

 

[jindon]

Yup, I missed it.

Very good.