slight tweek to macro if Possible???
Hello everyone.
Many thanks to Krish and Jindon for your help so far.
I'll try and explain in this post where I am now with a macro some of you have all helped me with, which I'm very grateful for, and what I'd like it to be able to do. (Just tweek it slightly).
OK. just to explain what I'm trying to do,
=========================
I have a big keyword phrase list.
maybe 10,000 lines of phrases.
I would like a button that on a new sheet creates the following;
The button would pop up and in it you would type a word or phrase. It then on a new sheet returns all the lines of phrases found from the main keyword list that contain the said word or phrase on separate rows in the new sheet.
So;
3 separate columns ;
Column 1 on the sheet would be called “Keyword Phrases” this is the heading and would be in cell A1 .
Second column would be called “Unique Keywords” in cell C1.
And the
new third column I would like to have added would be called “ No Unique Keywords” in cell E1. (This would return the number of times the unique keyword has been found within the returned list, so it kind of gives the unique keywords a weighting of popularity, as the higher the number, so the more the unique keyword has been found, and as such is more popular.
All the results would be returned from row 3 onwards (So there are the headings, miss a row, then the results).
So far Krish who has been very helpful has written this macro which does 2 of the 3 columns;
========================================
Option Explicit
Sub TestIt_v01()
Dim sWS As Worksheet, _
rWS As Worksheet, _
FindStr As String
Dim n As Long, _
k As Long
Dim a, v, x, w(), j, i
Application.ScreenUpdating = False
Set sWS = Sheets("Main KW List") 'change to suit
FindStr = Application.InputBox("Siam Sites Niche Keyword Finder", "Keywords To Find")
If FindStr = "" Then Exit Sub
If Application.WorksheetFunction.CountIf(sWS.Columns(1), "*" & FindStr & "*") = 0 Then Exit Sub
With CreateObject("Scripting.dictionary")
With sWS.Range("A1:A" & sWS.Range("A" & Rows.Count).End(xlUp).Row)
a = .Value
End With
For Each v In a
If Not IsEmpty(v) And InStr(1, v, FindStr) > 0 And _
Not .exists(v) Then
.Add v, Nothing
End If
Next
x = .keys
End With
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Niche KW Result").Delete
Set rWS = Sheets.Add
rWS.Name = "Niche KW Results"
Application.DisplayAlerts = True
On Error GoTo 0
With rWS.Range("A1:A" & UBound(x) + 1)
.Resize(UBound(x) + 1, 1) = Application.Transpose(x)
.HorizontalAlignment = xlGeneral
.Columns.AutoFit
End With
With CreateObject("Scripting.dictionary")
For Each v In x
v = Trim(Replace(v, FindStr, ""))
i = Split(v, " ")
For j = 0 To UBound(i)
If Not IsEmpty(i(j)) And Not .exists(i(j)) And Not IsNumeric(i(j)) Then
k = k + 1: ReDim w(1 To k, 1 To 1)
w(k, 1) = i(j): .Add w(k, 1), Nothing
End If
Next j
Next v
rWS.Range("C1") = "Unique Keywords"
rWS.Range("C2").Resize(k, 1) = Application.Transpose(.keys)
rWS.Range("C2").Resize(k + 1, 1).Sort Key1:=rWS.Range("C2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
rWS.Range("C1").Resize(k + 1, 1).HorizontalAlignment = xlGeneral
rWS.Columns(3).AutoFit
End With
Application.ScreenUpdating = True
End Sub
=======================================
Also, Jindon has written a formula, but unfortunately I stll can't get it to work yet, still get an error message, but I think it's written more for the third column of what I'm trying to do; here it is anyway;
======================================
Sub test()
Dim ws As Worksheet, a, e, dic As Object, b(), m As Object
Dim n As Long, myTxt As String, txt As String
Set dic = CreateObject("Scripting.dictionary")
dic.CompareMode = vbTextCompare
On Error Resume Next
Sheets("Result").Delete
Sheets.Add.Name = "Reuslt"
On Error GoTo 0
myTxt = Application.InputBox("Enter a word",Type:=2)
ReDim b(1 To Rows.Count, 1 To 2)
With CreateObject("VBScript.RegExp")
For Each ws In Sheets
If ws.Name <> "Result" Then
a = ws.Range("a1",ws.Range("a" & Rows.Count).End(xlUp)).Value
If IsArray(a) Then
For Each e In a
If InStr(1,e,myTxt,1) > 0 Then
txt = Replace(e, MyTxt,"")
.Pattern = "[,\?\*\.\|\{\}\\\[\]\(\)!]"
.Global = True
txt = .replace(txt,"")
.Pattern = "\S+"
.Global = True
For Each m In .execute(txt)
If Not dic.exists(m.Value) Then
n = n + 1
b(n,1) = m.Value : b(n,2) = 1
dic.add m.Value, n
Else
b(dic(m.Value),2) = b(dic(m.Value),2) + 1
End If
Next
End If
Next
Else
If InStr(1,ws.Range("a1").Value, mtTxt,1) > 0 Then
txt = Replace(ws.Range("a1").Value, myTxt,"")
.Pattern = "[,\?\.\*\|\{\}\[\]\(\)!]"
.Global = True
txt = .replace(txt, "")
.Pattern = "\S+"
.Global = True
For Each m In .execute(txt)
If Not dic.exists(m.Value) Then
n = n + 1
b(n,1) = m.Value : b(n,2) = 1
dic.add m.Value, n
Else
b(dic(m.Value), 2) = b(dic(m.Value),2) + 1
End If
Next
End If
End If
End If
Next
End With
Set dic = Nothing : Erase a
On Error Resume Next
Sheets("Result").Delete
Sheets.Add.Name = "Result"
On Error GoTo 0
With Sheets("Result").Range("a1")
.Resize(,2).Value = [{"Word","# of appearance"}]
.Offset(1).Resize(n,2).Value = b
.CurrentRegion.Sort key1:=.Range("b1"), order1:=xlDescending, header:=xlYes
End With
End Sub
=====================================
So, if anyone can kind of combine the 2 formulas really in some way so that on the new sheet it finds as stated above. (I'll just reiterate it again
3 separate columns ;
Column 1 on the sheet would be called “Keyword Phrases” this is the heading and would be in cell A1 .
Second column would be called “Unique Keywords” in cell C1.
And the
new third column I would like to have added would be called “ No Unique Keywords” in cell E1.
All the results would be returned from row 3 onwards (So there are the headings, miss a row, then the results).
I really Hope someone can help me on this.
Everyone has been so helpful so far.
Hope it is possible to do this.
Many thanks Everyone
John Caines
