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]

OOps

Can you change it to

RowHeight

 

[John Caines]

Brilliant

Many Thanks Jindon.
It is fantastic,really brilliant
I also added though under your line of;
================================
.HorizontalAlignment = xlCenter (For Row 1) the following;
============================
.VerticalAlignment = xlCenter
============================

It seemed to work fine.
Just 2 questions, then that's it.
If I did want all the results that are returned to be a slightly larger font ,, how can I change that Jindon??
The results returned at the moment are Tahoma 8. (Sometimes this seems just a little small in size).
I've looked at your code, and can't see anywhere the number 8???? So I could change it to a 9 or 10.
Can you tell me where the line is that alters the returned results font size please Jindon?

Finally, it's being a bit fussy, but is it also possible to auto add the "Freeze Panes" function on the returned results on Row 3, so that when you scroll down, the headings and Totals always are showing at the top of the page still??

That's it then though Jindon.
Absolutely brilliant.
I'll have to think of project 2 now
Many many thanks for all your help,, and everyone in fact on this, including, and I must mention also Krish.
I could never have done this without all your help.

All the best.
A very grateful
John Caines

 

[jindon]

John
Seems your default font size is 8...

.
.
.
.
Sheets.Add.Name = "NicheKWresults" '<- replace from here
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
            .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

 

[John Caines]

Brilliant

It's Perfect Jindon.

Many many thanks.
Brilliant

Onto the next project now!

 

[John Caines]

new question- new feature if possible for macro

Hello Jindon,
Is it possible to add a feature to this macro, or would it need to be a completely different macro???
The feature I'd love to include would be the following;

If I want to list all the unique words from a keyword list, can this be done by inserting the word "all"
So, I have a large keyword list, and I want to list all the unique words (Still using the filtered ignore list within the macro).
Can I just click the macro button, the just type in the word "all" and it would list all the unique words from the keyword list????
The formula so far Jindon looks like the following;
======================================
Sub SiamSitesNicheKeywordFinder2()
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|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 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 .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
============================================
If this can't be done, then a new macro I suppose. But if this feature could be added to your existing macro that would be brilliant.

Hope you can help.

Many Thanks
John Caines

 

[Krishnakumar]

Hi,

Where do you want to write the word "all"? In an input box? or any cell in the worksheet?

 

[John Caines]

all

Hello Krish,
What I was thinking was;;;;
Instead of writing another macro for the sheet, if there is anyway of adding a feature to the code above?? So that if I wrote "all" in the pop up search box(Even in enclosed brackets if needs be, it would return all the unique words in a list along with all the other columns.

So basically, the code above at present works perfect. You type in a phrase or word, it looks at the keyword list and returns all the keyword phrases (That contain the words or phrases you've typed in the box) from the original keyword list, along with number of occurances etc etc.
I just thought, is there anyway to use the same macro, and just type in the search box "all", and it would just return a list of ALL the unique keywords in order of occurance etc.

If this is impossible to do, and add it to the same formula above, then I suppose it would have to be a new macro. (Then I have 2 buttons on my sheet and not 1 )

Someone did write a formula before which I think was meant to do what I wanted, but I did try it in a large list and it had a "Debug error". (On the line);
Range("A2").PasteSpecial
The formula is below;
================================
Sub UniqueKeywordsMacro()
Application.DisplayAlerts = False
Columns(1).Replace What:=" ", Replacement:=Chr$(10), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns(1).Copy
Workbooks.Add
Range("A2").PasteSpecial
With ActiveWorkbook
.SaveAs "C:\UniqueKeywordsMacro.prn", FileFormat:=xlTextPrinter
.Close
End With
Workbooks.OpenText "C:\UniqueKeywordsMacro.prn"
End Sub
=======================================
I'm not too sure what prn is??
anyway, I just thought I'd mention this formula.
But like I said, if the large formula mentioned previously can have an added function to return all unique keywords from the list if entering the word "all" in the search box, that would be amazing.

Many Thanks
I hope the above all makes sense.
John Caines

 

[Krishnakumar]

Hi John,

Try,

Sub SiamSitesNicheKeywordFinder2()
    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|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

Here you can type either all or any keyword. Let me know how it works.

 

[John Caines]

all

Thanks for that Krish,
Yes it seems to work fine!
Brilliant.
Now this macro has 2 distinct functions. Saves incorporating another button etc.

Many thanks for this.
Much appreciated.
All the best
A very happy John