How to Creating a Unique Keyword List?

[John Caines]

Dear Forum members,

Can anyone help me?
What I'm trying to achieve is the following;
I have a big keyword list saved in Excel.
Something like the following,
These are all keyword phrases;

car rent
car hire
cars for rent uk
etc etc etc

All listed in Column A

All phrases in Column A, and in separate rows.(1 phrase per row.)about 2000 lines (Rows) in total.
What I want to know is there any way of selecting the whole list and exporting it (To save it as another list. A list of just unique keywords??

So, It would create a list like;
car
rent
uk
hire
for
etc etc etc.

So basically I want excell to look at all the words and export them to another list showing just unique keywords, 1 per line.

This is so I can see from a huge list what all the unique keywords are.
Is there a way of doing this within Excel Now?? or has someone made a plugin ( Macro) to achieve this??
I've looked at the sort & filter options, but it doesn't appear to have this function?

Any thoughts on this would be great.
I've wanted to do this for ages and I'm a basic beginner in excel and just can't work it out.

Hope someone can help.
Many Thanks
John
Many Thanks
John

 

[jindon]

Try this one

It was "" character, It couldn't be caught by IsEmpty function...
Obviously because InEmpty function only works with Variant type data meanwhile Split function creates String type Array...

Sub Test()
Dim a, dic As Object, x, myTxt As String, b(), c(), n As Long, i As Long, e, s, myTotal As Long
myTxt = InputBox("SiamSites - Niche Keyword Finder")
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("Main KW List")
    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|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 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
    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 .Range("a1")
        .Resize(, 7).Value = Array("Phrases That Include: " & myTxt, "", "Unique Keywords", "", "No. Of Appearances", "", "% Of Appearances")
        .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
        End With
        .Offset(1).Resize(, 5).Value = Array("Total Phrases: " & i, "", "Total: " & n, "", "Total: " & myTotal)
    End With
    .Range("a:g").EntireColumn.AutoFit
End With
End Sub

 

[John Caines]

brilliant

Many thanks Jindon.
Works fine now.
Truely excellent.

1 more question though.

If I want bto run this macro without the "Words to ignore" line of code,
what would the formula be???????

I trie the code without these 3 lines'
===================================
.Pattern = "[\n\f\r\t\v]|(\b([a-z0-9:\;&\+-/\|\\]{1}|200|\d{2}|by|do|fe|ga|not|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
===================================
But got an error??????
Is there a way to conduct the search without the ignore list, and what would the code be????

Again, many many thanks for this.

Off to work now
All the best
John Caines

 

[jindon]

try

Sub TestWithoutIngore()
Dim a, dic As Object, x, myTxt As String, b(), c(), n As Long, i As Long, e, s, myTotal As Long
myTxt = InputBox("SiamSites - Niche Keyword Finder")
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("Main KW List")
    a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
End With
For Each e In a
     If InStr(1, e, myTxt, 1) > 0 Then
        i = i + 1: b(i, 1) = e
        x = Split(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
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 .Range("a1")
        .Resize(, 7).Value = Array("Phrases That Include: " & myTxt, "", "Unique Keywords", "", "No. Of Appearances", "", "% Of Appearances")
        .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
        End With
        .Offset(1).Resize(, 5).Value = Array("Total Phrases: " & i, "", "Total: " & n, "", "Total: " & myTotal)
    End With
    .Range("a:g").EntireColumn.AutoFit
End With
End Sub

 

[John Caines]

It worked also

Hello Jindon.
Just got in from work and tried the new formula.
Looks a lot different, but works fine! Brilliant.
Many thanks for this.

No way could I have written this myself.
The Macro you've written I'll be saving on my hard drive for sure, (In Triplicate)

I do have a question again though relating to it Jindon.

I did what you told me to do earlier in the post and save my template I created.
I'll be saving the template with your macro in.
I learnt a couple of days ago about "Conditional Formatting", so I've created the rows to appear alternating in colour. The sheet looks great now. 1st row white (Std) second row a custom colour (Light Grey).
Also all my headings are in Bold and centred in a light blue fill colour.

My question is;;
The macro you've written Jindon.
If I gave you specifics,
can it return results in a formatted style????
As at the moment the headings are to the left of a cell and not bold etc.

Can it be written so that the headings are centred and bold text etc????

If this is possible I can give you specifics on the formatting.
Actually if I list then now, and if you can do it, brilliant!
If not, no worries as your formula is brilliant anyway, it's just that I created a nice template and when the results get returned it's all on a std white sheet with no formatting

I'll leave the information now if you can do it.
Whatever though Jindon,, many many thanks for all your trouble with this. Truly.

Formatting if possible;
=====================================
Row 1 returns all title headings. Can Row 1 be "21" in height
Row 1 fill colour; "Light Blue" (Standard Excel palette colour) RGB colour is;51,102,255 or in HTML #3366FF
Row 1 Text for Headings=Bold ,Font=Tahoma, Size=11 All centred

All Row 2 Data=centred But just std (IE not Bold or in Blue fill colour, font size 9 Tahoma)

All results Tahoma size 8, everything else with the results returned, just exactly the same as what's already returned. (No Changes)

Finally, All rows alternating in colour.
(I learnt Jindon how to do this 2 days ago,, I used this;
=MOD(ROW(),2)=0
I'm not sure what it means, but I read about it and it worked.
The alternating colours would be

1. First Row White (STD)
2. Second Row A custom Light Grey. RGB240,240,240 HTML#F0F0F0
And the Border outlines for the cells to be Grey
RGB157,157,161 HTML#9D9DA1
(So these 2 colours would alternate all down the page.
Macro to be altered, the one with the ignore list included if possible.
===========================================

That's it Jindon.
If this can be done it means the results would be returned in a similar nice format.
I wish I could send you the template Jindon.
It looks really good new.

Again, if this can be done ,, Brilliant, but if you can't format the macro then no worries. It's great as it is, but the formatting would just make it look so professional.

Many thanks again.
Off to bed now.
All the best
John Caines

 

[John Caines]

Forgot to mention

By the way Jindon,
You wrote;
====================================
"it was "" character, It couldn't be caught by IsEmpty function...
Obviously because InEmpty function only works with Variant type data meanwhile Split function creates String type Array... "
====================================

Maybe 1 day I'll understand what the hell this means
I'm really excited that I've just learnt how to change row colours Alternating!
God knows how long it will take me to learn what the above means

John

 

[jindon]

John
If any other change, let me know
And this part is common to both codes

.
.
.
.
.
With Sheets("NicheKWresults")
    With .Range("a1")
        With .Resize(, 7)
            .Value = Array("Phrases That Include: " & myTxt, "", "Unique Keywords", "", "No. Of Appearances", "", "% Of Appearances")
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
        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
            .FormatConditions.Add type:=xlExpression,Formula1:="=mod(row(),2)=0"
            .FormatConditions(1).Interior.Color = RGB(240,240,240)
            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
        End With
        With .Offset(1).Resize(, 5)
            .Value = Array("Total Phrases: " & i, "", "Total: " & n, "", "Total: " & myTotal)
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
        End With
    End With
    .Range("a:g").EntireColumn.AutoFit
End With
End Sub

"" was produced when Ingored word converted to ""
then again, IsEmpty function only works with Variant type data, but the data we are dealing with is String type data, so the syntax should be s <>"",instead of Not IsEmpty(s).

 

[John Caines]

Thanks Jindon-But Problem

Thanks for the reply Jindon,
I wasn't quite sure where to insert the new piece of code? But I've inserted it now to look like the following;
=====================================
Sub SiamSitesNicheKeywordFinder()
Dim a, dic As Object, x, myTxt As String, b(), c(), n As Long, i As Long, e, s, myTotal As Long
myTxt = InputBox("SiamSites - 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|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 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
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 .Range("a1")
.Resize(, 7).Value = Array("Phrases That Include: " & myTxt, "", "Unique Keywords", "", "No. Of Appearances", "", "% Of Appearances")
.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
End With
.Offset(1).Resize(, 5).Value = Array("Total Phrases: " & i, "", "Total: " & n, "", "Total: " & myTotal)
End With
.Range("a:g").EntireColumn.AutoFit
With .Range("a1")
With .Resize(, 7)
.Value = Array("Phrases That Include: " & myTxt, "", "Unique Keywords", "", "No. Of Appearances", "", "% Of Appearances")
.HorizontalAlignment = xlCenter
.Font.Bold = True
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
.FormatConditions.Add Type:=xlExpression, Formula1:="=mod(row(),2)=0"
.FormatConditions(1).Interior.Color = RGB(240, 240, 240)
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
End With
With .Offset(1).Resize(, 5)
.Value = Array("Total Phrases: " & i, "", "Total: " & n, "", "Total: " & myTotal)
.HorizontalAlignment = xlCenter
.Font.Bold = True
End With
End With
.Range("a:g").EntireColumn.AutoFit
End With
End Sub

============================================
Several points (I'll attach a screen capture also.
Row 1 is all centered and bold which is perfect. But 3 things missing really.
1. Row 1 to have a larger height of "21"
2.Row 1 also to have a fill colour of Blue. RGB 51,102,255
3. Font size in Row 1 to be "11"
Also all returned Fonts to be Tahoma.

Also Jindon, the sheet returned only 3 columns with an alternating row colour??
This was Row C,D,E (I'll attach the photo now.
=================================

New Microsoft Excel Worksheet.xls
	A	B	C	D	E	F	G
1	PhrasesThatInclude:web		UniqueKeywords		No.OfAppearances		%OfAppearances
2	TotalPhrases:4453		Total:303		Total:22990
3
4
5	3dflashwebdesign		web		4538		19.74%
6	3dflashwebdesignasia		design		2523		10.97%
7	3dflashwebdesignthailand		site		1966		8.55%
8	aecommercewebpagehost		hosting		1380		6.00%
9	aecommercewebpagehostasia		asian		1115		4.85%
10	aecommercewebpagehostthailand		asia		1113		4.84%
11	awebhostingwebsitedesign		thailand		1113		4.84%
12	awebhostingwebsitedesignasia		ecommerce		1035		4.50%
13	awebhostingwebsitedesignthailand		free		795		3.46%
14	aaadesignhostingsiteweb		page		452		1.97%
NicheKWresults

=======================================
For some reason Jindon, the attached photo doesn't show Colunm C,D,E with the lighter grey alternating rows.(Also the grey rows don't have the grey border lines to them also.

I'll try and send you an email in HTML so hopefully you can see the grey lines. I would attach a jpeg but you can't receive attachments??

Hope this makes sense Jihn.
I hope I inserted your code in the right place

Many Thanks again
John Caines

 

[jindon]

John
Wrong place...
Replace the code from here to End Sub

.
.
.
.
Sheets.Add.Name = "NicheKWresults" '<- replace from here
With Sheets("NicheKWresults")
    .Cells.Font.Name = "Tahoma"
    With .Rows(1)
        .Height = 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
            .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
            .Font.Bold = True
        End With
    End With
    .Range("a:g").EntireColumn.AutoFit
End With
End Sub

 

[John Caines]

still error Jindon?

Hello Jindon,
Thanks for the reply.
I've just got in from work (4.30AM)

Still a debug error I'm affraid Jindon
This is the line of the error
The error number that came up by the way was 1004?????
It Said "Unable to set the Height properly of the Range class"??

The line error was;
================================
.Height = 21
================================

The code looks like this now Jindon (Hope I've inserted it right now)
====================================
Sub SiamSitesNicheKeywordFinder()
Dim a, dic As Object, x, myTxt As String, b(), c(), n As Long, i As Long, e, s, myTotal As Long
myTxt = InputBox("SiamSites - 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|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 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
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")
.Cells.Font.Name = "Tahoma"
With .Rows(1)
.Height = 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
.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
.Font.Bold = True
End With
End With
.Range("a:g").EntireColumn.AutoFit
End With
End Sub
===========================================
Not sure why it has a problem with the row Height?? I've tried a few things (Guessing) but I couldn't get it to work.

Hope you can help.

Many Thanks Jindon
John

 

[John Caines]

still error Jindon?

Hello Jindon,
Thanks for the reply.
I've just got in from work (4.30AM)

Still a debug error I'm affraid Jindon
This is the line of the error
The error number that came up by the way was 1004?????
It Said "Unable to set the Height properly of the Range class"??

The line error was;
================================
.Height = 21
================================

The code looks like this now Jindon (Hope I've inserted it right now)
====================================
Sub SiamSitesNicheKeywordFinder()
Dim a, dic As Object, x, myTxt As String, b(), c(), n As Long, i As Long, e, s, myTotal As Long
myTxt = InputBox("SiamSites - 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|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 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
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")
.Cells.Font.Name = "Tahoma"
With .Rows(1)
.Height = 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
.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
.Font.Bold = True
End With
End With
.Range("a:g").EntireColumn.AutoFit
End With
End Sub
===========================================
Not sure why it has a problem with the row Height?? I've tried a few things (Guessing) but I couldn't get it to work.

Hope you can help.

Many Thanks Jindon
John