search for the keywords and copy paste to another sheet

[sindhuja]

Hi,

I have a excel with 2 sheets.

Sheet named "keyword" has list of words (minimum 10 words)

Sheet names "master" is the source in which i have to search for the keywords and copy paste the results in another new sheet.

words to be searched in the info 1,2,3,4 columns. Each word in keyword sheet should be searched in all the info columns.

Can anyone assist me with my requirement. i have attached the sample sheet for the reference.

Thanks,
Sinduja

[sindhuja]

[Yongle]

There are several other ways to tackle this one, but this should give you what you want.
I have attached original worksheet with the macro included. I have added a sheet "result2", so that you can compare this against what you expected (per sheet "result"). Some of the items in your original "result" do not appear to match anything on the keyword list.
Assumption:
Assumes that you want an EXACT match for the keyword - so if keyword list includes "gift" only "gift" will be matched NOT "gifts"
Assumes there are no blank cells in columns A
How it works:
An array is set up to hold each keyword (arrayK)
Each value in columns E to H are compared in turn against each value in array
If there is a match, that row is copied to sheet "result2"
Finally, any duplicates that would occur if there are matches in more than one column within the same row are removed
The line of code wsR.Cells.ClearContents clears away all the previously copied values each time the macro is run. Pasting always begins at row2

Sub Search_Key_Words()

'declare and set variables
    Dim LastRowK As Long, LastRowM As Long
    Dim r As Integer, c As Integer, w As Integer, x As Integer, y As Integer, z As Integer
    Dim arrayK() As Variant
    Dim wsM As Worksheet, wsR As Worksheet, wsK As Worksheet
    Set wsM = Sheets("master")
    Set wsR = Sheets("result2")
    Set wsK = Sheets("Keyword")
'clear old values in results sheet
    wsR.Cells.ClearContents
'determine last row
    LastRowK = wsK.Range("A1").End(xlDown).Row
    LastRowM = wsM.Range("A1").End(xlDown).Row
'set dimensions of array
    ReDim arrayK(LastRowK - 2)
'place keywords in array
    For x = 0 To LastRowK - 2
        arrayK(x) = wsK.Cells(x + 2, 1)
    Next x
'create header row and set first row for data in results sheet
     wsM.Range("A1:H1").Copy
     wsR.Range("A1:H1").PasteSpecial xlPasteValues
    z = 2
'run through columns E to H and check for values to match keywords
    For w = 0 To LastRowK - 2
        For r = 2 To LastRowM
            For c = 5 To 8
                If wsM.Cells(r, c) = arrayK(w) Then
                    For y = 1 To 8
                    wsR.Cells(z, y) = wsM.Cells(r, y)
                    Next y
                    z = z + 1   'adds 1 to row number in results sheet
                Else
                'do nothing
                End If
            Next c
        Next r
    Next w
'remove duplicate entries - could happen if keyword matches appear in more than one column
    wsR.Range("A2:H" & z - 1).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8), Header:=xlNo
End Sub

[sindhuja]

Thank you so much for the assistance.

Can this be modified such as they key word searches are not for the EXACT words.

Even if it is "gift" or "gifts" it should be considered.

This is the sample sheet I have attached with few columns and rows. Will this work for the dynamic rows and column.

Also, the result2 should be amended for each search. If I run the macro again, the results should be after the last row of the result2 sheet.

sorry if am not clear in my earlier post.

-Sindhuja

[Yongle]

Let's take everything one item at a time.
If you do not want it to be an exact match, you need to be very careful that you do not make the condition too loose. So you need to decide what is allowed and what is not allowed.
Shall we say that if the string begins with "tax" then it is a match? so taxes, taxation, taxidermy, taxonomy are a match?

[Yongle]

This is the sample sheet I have attached with few columns and rows. Will this work for the dynamic rows and column.

Yes it will work for dynamic rows
No it will not work for dynamic columns - are you planning to add columns?

[Yongle]

Also, the result2 should be amended for each search. If I run the macro again, the results should be after the last row of the result2 sheet.

It is easy to amend the macro to add the next results to the bottom of the range. Will all values in sheet "master" be new each time you run the macro?

[Yongle]

Code amended to reflect your comments

(1) Can this be modified such as they key word searches are not for the EXACT words. Even if it is "gift" or "gifts" it should be considered.

Have replaced "EQUAL TO" with "LIKE" plus the wildcard "*" which means that any word beginning with the keyword will be matched.
If keyword is tax, matches could be tax, taxed, taxes, taxi etc
If keyword is taxes, only taxes would be matched from above list because it is the only one beginning with those 5 letters.
So the code becomes:

If wsM.Cells(r, c) Like arrayK(w) & "*" Then

(2) Also, the result2 should be amended for each search. If I run the macro again, the results should be after the last row of the result2 sheet.

Previous results are now retained and, by using a new variable LastRowR to set the starting point for variable z, results are now added after the last row of "result2"

(3) This is the sample sheet I have attached with few columns and rows. Will this work for the dynamic rows and column.

The rows are dynamic - so we do not need to amend anything
The columns are not dynamic.
The code is now amended to work for up to 12 columns (A to L). To amend it to reflect the number of columns in your worksheet, make changes as follows - replace 12 with the number of columns in your worksheet:

For y = 1 To 12

Amend in 3 lines the "L" to match your last column and amend the array to reflect the number of columns

 wsR.Range("A2:L" & z - 1).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), Header:=xlNo

wsM.Range("A1:L1").Copy
wsR.Range("A1:L1").PasteSpecial xlPasteValues

The spreadsheet with my test data is attached.

Amended macro:

Sub Search_Key_Words()

'declare and set variables
    Dim LastRowK As Long, LastRowM As Long, LastRowR As Long
    Dim r As Integer, c As Integer, w As Integer, x As Integer, y As Integer, z As Integer
    Dim arrayK() As Variant
    Dim wsM As Worksheet, wsR As Worksheet, wsK As Worksheet
    Set wsM = Sheets("master")
    Set wsR = Sheets("result2")
    Set wsK = Sheets("Keyword")
'determine last row
    LastRowK = wsK.Range("A1").End(xlDown).Row
    LastRowM = wsM.Range("A1").End(xlDown).Row
    If wsR.Range("A2") = "" Then
    LastRowR = 1
    Else
    LastRowR = wsR.Range("A1").End(xlDown).Row
    End If
'set dimensions of array
    ReDim arrayK(LastRowK - 2)
'place keywords in array
    For x = 0 To LastRowK - 2
        arrayK(x) = wsK.Cells(x + 2, 1)
    Next x
'create header row and set first row for data in results sheet
    wsM.Range("A1:L1").Copy
    wsR.Range("A1:L1").PasteSpecial xlPasteValues
    z = LastRowR + 1
'run through columns E to H and check for values to match keywords
    For w = 0 To LastRowK - 2
        For r = 2 To LastRowM
            For c = 5 To 8
                
                If wsM.Cells(r, c) Like arrayK(w) & "*" Then
                    For y = 1 To 12
                    wsR.Cells(z, y) = wsM.Cells(r, y)
                    Next y
                    z = z + 1   'adds 1 to row number in results sheet
                Else
                'do nothing
                End If
            Next c
        Next r
    Next w
'remove duplicate entries - could happen if keyword matches appear in more than one column
    wsR.Range("A2:L" & z - 1).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), Header:=xlNo
End Sub

[jonh]

Maybe you could use a query.

Copy the code to notepad, edit the file path and save with a dqy extension.

Run the file, copy the table where you want it and then you can just use 'refresh all' on the data menu.

XLODBC
1
DSN=Excel Files;DBQ=C:\Sampple.xlsx;
SELECT `master$`.* FROM `C:\Sampple.xlsx`.`master$`, `C:\Sampple.xlsx`.`keyword$` where (instr(1,`master$`.`info1 ` & ' ' & `master$`.info2 & ' ' & `master$`.info3 & ' ' & `master$`.info4,`keyword$`.Keywors))

[sindhuja]

Hi All,

Thank you so much for all your help.

One last question - we have used arrary for the columns. If the columns are more than 50 do we need to use the numbers like 1,2,3,4..... 50..

or can this be done the other way.

-sindhuja

[Yongle]

One last question - we have used arrary for the columns. If the columns are more than 50 do we need to use the numbers like 1,2,3,4..... 50..
or can this be done the other way.

Your earlier posts did not mention that there would be quite so many columns. I have amended the code to make the columns dynamic too.
You will see that I have added 2 variables LastCol and strLastCol
These hold the last column number and the last column alpha element respectively.
I have highlighted the changes in the code.
The addition of dynamic arrayR avoids the 1,2,3....50.. problem
The spreadsheet with my test data is attached
If the code is now achieving what you need, can you go to "thread tools" and mark this thread as "solved" - thanks

Sub Search_Key_Words()


'declare and set variables
    Dim LastRowK As Long, LastRowM As Long, LastRowR As Long, LastCol As Long    Dim r As Integer, c As Integer, w As Integer, x As Integer, y As Integer, z As Integer
    Dim arrayK() As Variant, arrayR() As Variant
    Dim wsM As Worksheet, wsR As Worksheet, wsK As Worksheet
    Dim strLastCol As String
    Set wsM = Sheets("master")
    Set wsR = Sheets("result2")
    Set wsK = Sheets("Keyword")
'determine last rows/column
    LastRowK = wsK.Range("A1").End(xlDown).Row
    LastRowM = wsM.Range("A1").End(xlDown).Row
        If wsR.Range("A2") = "" Then
    LastRowR = 1
        Else
    LastRowR = wsR.Range("A1").End(xlDown).Row
        End If
    LastCol = wsM.Range("A1").End(xlToRight).Column
'Last column letters ( ie column A or BQ etc)
    strLastCol = Split(wsM.Range("A1").End(xlToRight).Address, "$")(1)
'set dimensions of arrays
    ReDim arrayK(LastRowK - 2)
    ReDim arrayR(LastCol - 1)
'place keywords in array
    For x = 0 To LastRowK - 2
        arrayK(x) = wsK.Cells(x + 2, 1)
    Next x
'create header row and set first row for data in results sheet
    wsM.Range("A1:" & strLastCol & "1").Copy
    wsR.Range("A1:" & strLastCol & "1").PasteSpecial xlPasteValues
    z = LastRowR + 1
'run through columns E to H and check for values to match keywords
    For w = 0 To LastRowK - 2
        For r = 2 To LastRowM
            For c = 5 To 8
                'If wsM.Cells(r, c) = arrayK(w) Then
                If wsM.Cells(r, c) Like arrayK(w) & "*" Then
                    For y = 1 To LastCol
                    wsR.Cells(z, y) = wsM.Cells(r, y)
                    Next y
                    z = z + 1   'adds 1 to row number in results sheet
                Else
                'do nothing
                End If
            Next c
        Next r
    Next w
'remove duplicate entries - could happen if keyword matches appear in more than one column
    For c = 0 To UBound(arrayR)
        arrayR(c) = c + 1
    Next c
    wsR.Range("A2:" & strLastCol & z - 1).RemoveDuplicates Columns:=(arrayR), Header:=xlNo
End Sub