custom filter

[John Caines]

Hello all,
"Houston,I have a problem!"

A while ago I put a post up for a custom macro, in which mainly Jindon and Krishna helped me tremendously with, and to which I'm still very grateful.
Basically, I sort though large keyword phrase lists.

The macro that they made for me works brilliantly finding words or phrases from a large list with other data attached (IE no. of unique words etc)

What I'm trying to do now is clean up my list.
For example;
Say I have a list of 30,000 keywords/phrase for the main root word of "furniture."
All the phrase returned should be related to the word furniture. (Most are)
But quite a lot aren't.
I use some keyword analysis software that creates large lists but unfortunately some of the words or phrases returned aren't relevant.

What I need if possible is as follows;

I want to use the custom filter really but I can't see a function for what I need.
What I want is quite simple.;;

To be able to sort the list of phrases (From ColA,,actually A3 onwards as I have a header graphic inserted across the top 2 rows of my worksheet) by "No of Characters."

Quite simple I suppose, but I can't see this function anywhere.
Sort A-Z, yes fine,, but I want to sort by No of characters so numbers like 1,2,3,123,1943, etc and words like, uk,ny,b,co etc are all displayed first.
Then I can delete these if needs be.

Actually there is another part to this macro I'd love to have if it's possible.
Once I click the macro button, the list is sorted by no, of characters.
What I then want to be able to do is as follows;

Now this really might be another macro or sheet actually. So not on the same sheet as the main keyword list.
So, I highlight say 250 very short non related characters/numbers etc.
I then CUT these and paste them to a new blank sheet (Probably from ColA 3 again on this new blank sheet)
This Sheet I would like to be called "Character Lookup"
So now I have 250 non related phrases in the blank sheet.
What I would like to be able to do is as follows;
Click a macro button, and returned in ColC of this new sheet is only characters from the 250 list that ARE NOT listed in he Large 30,000 keyword list.
And by this I mean as seperate words.
So for example;
If in the list of 250 That I want to search for in the main 30,000 keyword list is say the character "ny".
the macro needs to look for "ny" with a space either side of it , so treating it as a word.
Or it will error and might say, "Yes it is in the big keyword list, when in fact it might be the word "any" and the macro has just seen the "ny" in the word "any".
I hope this makes sense.
So the macro in ColC will return only words from this 250 character list that ARE NOT in the main 30,000 keyword list.
This is so I can see if say 20 different numbers or small words/characters are returned in ColC, I can then delete the 230 From Col A, and If I want, Cut and Paste back the 25 found in ColC to the main 30,000 keyword list, as these are unique, and don't already appear in the main list.

Again,I hope all this makes sense.
As to formatting also,,,
If possible for the new Sheet (This second macro, can it have the same formatting as the following Macro Jindon & Krish Coded if possible??)
Can Col A2 heading be called "Characters To Be Sorted" and Col C2 be called "Characters To keep".


Hope someone can help me
Many Thanks
John Caines
Example of my sheets formatting
----------------------------------------------------

FurnitureWOW-Niche Furniture Keyword Finder.xls
	A	B	C	D	E
1
2	KeywordPhrase	ParentKeyword	FoundOn
3	.comfurniturevillage
4	10132chairfurnitureitalianleatherset
5	1200clearancefurniture
6	1600buydoorfurnitureirving
7	18thaftercabinetcenturyfurnituremakernamedstyle
8	18thantiquecenturyfurniture
9	18thantiquecenutryfurniture
10	18thcabinetcenturyenglishfurnituremakerstyle
11	18thcabinetcenturyfurnituremaker
12	18thcenturyamericanfurniture
13	18thcenturyenglishfurnituremaker
14	18thcenturyenglishfurnituremakername
All KWs

-----------------------------------------------------
Macro used for sorting, which includes the formatting for the new macro sheet

----------------------------------------------------------------
Sub FurnitureWOWNicheKeywordFinder()
Dim a, dic As Object, x, myTxt As String, b(), c(), n As Long, i As Long, e, s, myTotal As Long
myTxt = InputBox("FurnitereWOW - 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

-------------------------------------------------------------

I do hope someone can help me with this.
Everyone has been so helpful with my previous Macro request.
I hope this all makes sense.
Again
Many Thanks
John Caines