Multi Keyword Phrase Finding Macro

John Caines

Well-known Member
Joined
Aug 28, 2006
Messages
1,155
Office Version
  1. 2019
Platform
  1. Windows
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:
Code:
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
ABCDEFGHIJ
1Occur2WordPhrasesOccur3WordPhrasesOccur:4WordPhrasesOccur5WordPhrasesOccur6WordPhrases
2Total: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
 
I'll just try

God you type quick:)
I didn't read your post previous to the 1 I just posted:)

I'll try your suggestion now,
Many Thanks
John Caines
 
Upvote 0

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Almost there:)

Jindon,

Changing just those few lines of code have made all the difference:)
It's now returning results throughout the sheet:)
Madness!!
It's great.
I'll post now your formula exactly as it is in my sheet now for pure clarity.
Here is the code exactly as it stands now;
Code:
Sub MultiKeywordFinder()
    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("Sheet1").Range("a1")
         For i = 1 To UBound(b, 2)
              If dic.exists(i) Then
                   .Offset(, n).Value = "No of " & i & " word Phrases"
                   .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 With
End Sub

I'm not sure why it runs with 2 end withs at the end and not 1?:)
Ok, onto the results,
===============================================
Firstly Jindon, COL G & H I HAVE CHANGED JUST TO SHOW VISUALLY HOW THE RESULTS
SHOULD COME BACK.
THESE 2 COLUMNS I'VE ALTERED MYSELF, JUST TO POINT OUT VISUALLY THE CHANGES
I THINK ARE NEEDED LISTED BELOW. :)
===============================================
My Keyword Sort Sheet.xlsm
ABCDEFGH
1Noof1wordPhrasesNoof2wordPhrasesNoof3wordPhrasesOccur4WordPhrases
2Total:17atlantahomesforrentTotal:1832ndhomesTotal:260acliforniarentalhomesTotal:26Total:291
31eharmonhomes199homes1alabamamanufacturedhomes6albertahomesforrent
41escapehomes1ablihomestay1altantarentalhomes5albertahomesforrent
53fish4homes1acrdinalhomes1amazingvacationhomes3arizonahomesforrent
61fsih4homes1adllastownhomes1ancientromanhomes2arizonahomesforsale
71hearmonhomes1ahrmonhomes1apartmenttownhomeshouston1atlantahomesforrent
81240homes4arizonahomes1arizonarentalhomes1atlantahomesforsale
91homes4rent1arubahomes1asalnhomesllc1atlantahomesotrent
101homesaerch1ashevillehomes1ashevilleluxuryhomes1atlantahomestorent
111homesearch1aslanhomescom1aslanhomesllc1atlantaluxurygolfhomes
121homeseller7atlantahomes1atlantaluxuryhomes1austinhomesforlease
131homesforsale1atlantatownhomes1atlantarentalhomes1beachhomesforsale
145homestead1atlatnahomes1austinareahomes1beavertonhomesforsale
151homestore1augustahomes1bergencountyhomes1bozemanhomesforsale
161homestudy2austinhomes2bigskyhomes1brooklynhomesforsale
Sheet1




Changing those few lines of code Jindon has now meant that ColA,C,E,G,I etc etc are returning
Number of Ocurrences for their repective phrases.
Brilliant.

Just a few points that I can see that need altering Jindon. Those are as follows;,

1. Results in Col B,D,F,H,J etc etc are being returned on row 2.
They need to start from Row 3.
As in Row 2 there should be the word "Total:"
(So will look like my altered ColH,,,,,H2.)

2.All returned phrases to be returned in order by Number of appearances, so the most
first. So, for example, Col B (B8) this cell has the word homes that appeared 1240 times.
So, this would be to of the 1 word phrases and would be in cell B3.

3. The sheet is only returning data to row number 16. After Row 16 there is no data being returned. So, any other phrases are not being listed.
All data stops at row 16?

That's it for now Jindon, it really is getting close for sure.
Hope the above makes sense.
Just remember that I've changed Col G & H in the screen capture just so you can visually see what the columns should be like when 100% :)

Many thanks Jindon.
All the best
John Caines
 
Upvote 0
change to
Code:
    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"
                   With .Offset(2,n).Resize(maxR)
                        .formulaR1C1 = _
                         "=if(rc[1]<>"""",countif(" & myRange & ",""*""&rc[1]&""*""),"""")"
                         .Value = .Value
                   End With
                   .Offset(1, n).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 Resume Next
                   End With
                   n = n + 2
              End IF
         Next
    End With
End Sub
 
Upvote 0
kind of:)

Many thanks Jindon,

It took a while,, but what was strange was when I opened the sheet
All I could see was information in the " 4 word phrases" column??

So, I scrolled down,, and all the information is inverted Jindon.
I mean the column headings are at the top but all the returned data is at the very bottom of the sheet starting from Row 5117???

Any ideas Jindon?
I'll attach 2 screen shots, 1 from looking at the first few rows, and 1 from the last.
Good news though.
The data is coming back in order of appearance:)
So, from the below screen shot you can see all "4 Word Phrases" are in order of appearance.
Brilliant:)

Here's the screen shot anyway;
My Keyword Sort Sheet.xlsm
ABCDEFG
1Theactual#of2wordappearancesTheactual#of3wordappearancesTheactual#of4wordappearancesTheactual#of5wordappearances
2Total:1Total:830Total:5115Total:2719
3  234realestateforsale 
4  72northcarolinarealestate 
5  54newhampshirerealestate 
6  52southcarolinarealestate 
7  45newyorkrealestate 
8  41newmexicorealestate 
9  37century21realestate 
10  37departmentofrealestate 
11  35lasvegasrealestate 
12  25costaricarealestate 
13  25losangelesrealestate 
14  21schoolofrealestate 
15  18newjerseyrealestate 
16  17sandiegorealestate 
17  15coldwellbankerrealestate 
18  14realestateinma 
19  14sanfranciscorealestate 
Sheet1


I'll attach another of the bottom Jindon.
Many Thanks
John Caines
 
Upvote 0
bottom screenshot
My Keyword Sort Sheet.xlsm
ABCDEFGH
5107 1wilmingtonrealestate1yorkparealestate1wisconsindellswirealestate
5108 1woodinvillerealestate1yorkrealestatelawyers1wisconsinrealestateconditionreport
5109 1wrenthamrealestate1youngrealestatedeveloper1wisconsinrealestateforsale
5110 1wyattrealestate1yucatanmexicorealestate1wisconsinrealestatemlslisting
5111 1wyomignrealestate1yuccavalleyrealestate1worcestercountymarylandrealestate
5112 1wytatrealestate1yumaarizonarealestate1yahoorealestatehomevalues
5113 1yaakrealestate1yumacountyrealestate1yahoorealestatemortgagecalculator
5114 1yaohorealestate1zackwilliamsrealestate1yorkbeachmainerealestate
5115 1yemenrealestate1zanesvilleohiorealestate1yorkcountymainerealestate
5116 1ysdneyrealestate1zillionrealestatevalues1zephyrrealestatesanfrancisco
51179427realestate1zermattrealestate1zionsvilleindianarealestate1zillowhomepricesrealestate
Sheet1
 
Upvote 0
change to
Code:
    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"
                   With .Offset(2,n).Resize(maxR)
                        .formulaR1C1 = _
                         "=if(rc[1]<>"""",countif(" & myRange & ",""*""&rc[1]&""*""),"""")"
                         .Value = .Value
                   End With
                   .Offset(1, n).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 Resume Next
                   End With
                   n = n + 2
              End IF
         Next
    End With
End Sub
 
Upvote 0
Working:) Great news!

Jindon,
Great news!!!!
That seems to have done it!:)

Getting results now in the correct order:)
Brilliant.

I'll post now for clarity exactly what code I have entered into VB;
Code:
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("Sheet1").Range("a1")
         For i = 1 To UBound(b, 2)
              If dic.exists(i) Then
                   .Offset(, n).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).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 Resume Next
                   End With
                   n = n + 2
              End If
         Next
    End With
    End With
    
End Sub

It wouldn't run without 2 "End With" lines of code? Not sure why?
I'll also attach a screen shot now of it's returned results.
==============================================================
My Keyword Sort Sheet.xlsm
ABCDEFGH
1Noof1wordPhrasesNoof2wordPhrasesNoof3wordPhrasesNoof4wordPhrases
2Total:17Total:183Total:260Total:291
31240homes130rentalhomes220homesforsale114homesforrentin
445townhomes54vacationhomes188homesforrent42renttoownhomes
55homestead34newhomes56rentalhomesin5homesinsanantonio
63fish4homes19luxuryhomes10homesinmi5homesinsandiego
71atlantahomesforrent16renthomes8townhomesforrent5mobilehomesforsale
81eharmonhomes14mobilehomes7homesforlease4ohiohomesforsale
91escapehomes9loghomes7homesincharlotte3californiahomesforrent
101fsih4homes9manufacturedhomes7vacationrentalhomes3countryhomesforsale
111hearmonhomes7atlantahomes6homesinma3homesforrentin
121homes4rent7homescharlotte5townhomesforsale3homesincharlottenc
131homesaerch7hudhomes4homesindenver3newhomesforsale
141homesearch7modularhomes4homesinmichigan3utahhomesforsale
151homeseller7oregonhomes4homesforrent2coloradohomesforsale
161homesforsale6beachhomes4lasvegashomes2homesforleasepurchase
171homestore6familyhomes4northcarolinahomes2homesforrentca
181homestudy5calhomes3homescharlottenc2homesforrentcharlotte
191otwnhomes5countryhomes3homesonsale2homesforsalecharlotte
Sheet1

===================================================================

Only a few things now really.
1. The formatting.
2. The headings in Row 1 and 2,,, for example A1 & 2 need to be moved along 1 column to
the right. So they are in line with the phrases returned.
3. The words "Total:" then need to be inserted in cells A2,C2,E2,G2 etc and this will give
the total amount of occurences of each of the individual phrases

As to the formatting Jindon,
I tried again looking at 1 of your other Marcos you wrote for me sometime ago.
I've tried incorporating the formatting to see if I could do it,,, No, but it did run:)
But no where near correct I think.
At least I tried again.
I'll post what I tried now, (No laughing please):)
Code:
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("Sheet1").Range("a1")
       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
        With .Range("a3", .Range("a" & Rows.Count).End(xlUp))
             a = .Value
             myRange = "'AllKWs'!" & .Address(1, 1, xlR1C1) '<- here
               .Value = Array("No of " & i & " word Phrases")
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
               .Interior.Color = RGB(51, 102, 255)
         For i = 1 To UBound(b, 2)
              If dic.exists(i) Then
                   .Offset(, n).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).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 Resume Next
                   End With
                   n = n + 2
              End If
         Next
    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
    .Range("a:g").EntireColumn.AutoFit
    .Select
    .Range("a3").Select
    End With
    ActiveWindow.FreezePanes = True
    End With
    End With
End Sub

What I was trying to do was the following;
1. All cells to have the font "Tahoma"
2.Font size, size '9' for whole sheet.
3.Rows1-To have a row height of "21"
4.Rows1-To have a font size of 11
5. Rows1-To have RGB fill colour of RGB:51:102:255
6.Text In Rows1 to be aligned center
7. Conditional formatting on rows 3 downwards, alternating row colours.
8.RGB colour 240,240,240 alternating (So its white rows then light grey rows.
9. All cell lines to be light grey colour not black, so RGB:240,240,240
10.All columns Auto fit
11.Freeze panes from row 3 downwards.

That's what I wanted and tried to do Jindon.
It ran (At least:) but just gave me 3 cells that were blue:(

At least 99% of the coding is correct now Jindon. It's really a great macro.
Just if you can sort out the points above it will be 100% brilliant:)
I wish I could have formatted it for you to save you the trouble, but well,
I'm not up to that point yet actually :(
Many thanks for all you help so far on this Jindon.
All the best
John Caines
 
Upvote 0
change to
Code:
    With Sheets("Sheet1").Range("a1")
         For i = 1 To UBound(b,2)
              If dic.exists(i) Then
                   .Offset(, n + 1).Value = "The actual # of " & i & " word appearances"
                   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 Sub
Other things regarding formatting, try it for youself.
You should refer the code that I gave you long time ago, it's all in there.
I need to go off-line.
 
Upvote 0
reply

Many thanks Jindon.
I've tried again regarding formatting.

Here is the formula now exactly as entered into VB.
Even though I've tried to copy this in from something you wrote a long
time ago, it's really been hard actually.
Taken me a few hrs:)
Trial and error.

It's running.
But I'm not sure I've put things in the correct places Jindon.
I'll post what I've tried to amend now.
So,
"Multi Keyword Macro" by Jindon
Formatting by John Caines (Well, kind of:))(Only taken me 5 hours:))Really!
Code:
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").Range("a1")
    	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
         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
                   .FormatConditions.Add Type:=xlExpression, Formula1:="=mod(row(),2)=0"
                   .FormatConditions(1).Interior.Color = RGB(240, 240, 240)
                   End With
                   n = n + 2
              End If
         Next
         End With
    .Select
    .Range("a1").EntireColumn.AutoFit
    End With
    ActiveWindow.FreezePanes = True
    
    MsgBox "Time Elapsed: " & Format(Timer - sTime, "#,##0.000") & " sec"
    
End Sub

I'll have to post about this tomorrow Jindon.
It's now 12.30am.
Man, I've tried so many different ways and swapped so many different
lines of code,, I'm confused and knackered:)
Trying it again now, and now the formatting isn't working like it was:(
Might need a complete reboot of PC I think.

I'll post tomorrow results as it looks and any errors etc.
It's almost there now for sure.

Just quickly,
Main 2 points.
1. When I run the macro for the first time on a search term (For example the word "homes")
It doesn't show any numbers of occurances in the columns next to the phrases?
But if I run it again on the same phrase straight after the first run,, it returns results
with No of Occurrences of Phrases,, ie in Col A,C,E,G etc etc.

Not formatted correctly:(
I had most of it working earlier, tried so many variations now,,, getting tired and confused:(
Last point;

Cells A1 C1,E1,G1,I1 etc needs the word "Occur" ,, I've tried to impliment this, just can't figure it.
I'm sure it's got to do with code line
Code:
.Offset(, n + 1).Value = "No #  " & i & " Word Phrases"

Also Jindon,
Cell A2,C2,E2,G2 etc etc needs the word "Total:" and will add the total of occurances for that respective column.
Again, I'm gussing, but I think it's to do with this line of code
Code:
.Offset(1, n + 1).Value = "Total : " & dic(i)
Not sure,, really:)

I've tried to put your timer Jindon.
Also tried to format Rows 1 & 2.
And tried to have alterating row colours thoughout the sheet and a "Freeze Panes" on Row 2.

Not quite working I think.
Must get to bed.
It's 1.25 am

Any info I've left out , I'll have to repost tomorrow Jindon.
As a note;
Here is your amended code before I tried formatting.
Code:
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 Sub

Many Thanks for all your help on this Jindon.
Really.
Many Thanks
John Caines
 
Upvote 0
Re: reply

1. When I run the macro for the first time on a search term (For example the word "homes")
It doesn't show any numbers of occurances in the columns next to the phrases?
But if I run it again on the same phrase straight after the first run,, it returns results
with No of Occurrences of Phrases,, ie in Col A,C,E,G etc etc.

I have no idea abou this

Not formatted correctly:(
I had most of it working earlier, tried so many variations now,,, getting tired and confused:(
Last point;

Cells A1 C1,E1,G1,I1 etc needs the word "Occur" ,, I've tried to impliment this, just can't figure it.
I'm sure it's got to do with code line
Code:
.Offset(, n + 1).Value = "No #  " & i & " Word Phrases"

Also Jindon,
Cell A2,C2,E2,G2 etc etc needs the word "Total:" and will add the total of occurances for that respective column.
Again, I'm gussing, but I think it's to do with this line of code
Code:
.Offset(1, n + 1).Value = "Total : " & dic(i)
Not sure,, really:)[/quote]
Can you just tell me how you wanted with the screenshot?
This is confusing.
 
Upvote 0

Forum statistics

Threads
1,214,952
Messages
6,122,458
Members
449,085
Latest member
ExcelError

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top