Thread: Macro to Search and Copy Multiple Keywords into Another Sheet

Hello there, just wanted to bump this up to see if I could get any help with this question. If you have any ideas at all feel freel to post a reply. Thank you!

Thanks Foxguy!

I'll take a look at this on Monday morning when I get back to my work computer. I really appreciate your efforts.

(as far as the sheet names went, I was just changing them to something that I could recognize so I could later edit them as needed)

Originally Posted by foxguy

There is no code in my file to copy & paste. I converted your InputBox to a Userform so that the user could easily type in more than 1 word. Otherwise the user would have to be given instructions on how to enter more than 1 word in the InputBox.

To move the Userform into your workbook:
1) Open the Project Explorer (Alt+F11 opens VBE, then Ctrl+R to open Project Explorer).
2) Find you workbook and my workbook (mine will be named "VBAProject(Macro to Search and Copy Multiple Keywords into Another Sheet)" and yours will be named "VBAProject(YourWorkbookName)")
3) Find the UserForm in my workbook, and drag & drop it into yours (left mouse click the userform & hold button down, move the cursor to your workbook and release mouse button)
4) Double click on the userform in Project Explorer (this will open the form for editing).
5) Double click on the form itself (not one of the boxes). This will open the code behind the form.
6) Find the sub named "SearchKeywords" and modify the sheet names in the section between the '****************

I apologize for all the trouble I'm giving you but I'm getting an error after I perform the steps you mentioned in your last post.

I get this error: "Run-time error '1004': Method "Range" of object'_Global" failied. When I click on debug it highlights this line:

Set rUsedRange = Range(Cells(1, 1), .Cells(.Rows.Count, .Columns.Count))

I think I am getting the error after the first time I try to run it, or after I click the command button twice. It also doesn't seem to be pasting the search results after I click once, the inbox just stays open and the workbook is unchanged. It's really weird. Below is how my code reads.

For reference, keywords are being searched from the first sheet in the workbook, this sheet is presently named "All Levels - Combined"....

Then the goal is to be able to have two key words searched and once, with the results pasted into sheet named "Sheet1"

Do you think these sheet names are the reason for the error? VBA code is confusing to read so maybe I changed the sheet names in the section you refered to incorrectly?

Here's the code copied and pasted from the viewing the code form "Userform1"

Option Explicit

Private Sub CommandButton1_Click()
    SearchKeywords TextBox1, TextBox2
End Sub

Private Sub SearchKeywords(sWord1 As String, Optional sWord2 As String)
    Dim aData()
    Dim aFoundData()
    Dim lRow As Long
    Dim lCol As Integer

    Dim shCopyFrom As Worksheet
    Dim shCopyHeadingsFrom As Worksheet
    Dim shCopyTo As Worksheet

    Dim lRows As Long
    Dim lCols As Integer
    Dim rUsedRange As Range

    Dim lNextRow As Long
    

    '******************************************
    'Set these to fit your workbook

    Set shCopyFrom = Sheets("All Levels - Combined")
    Set shCopyHeadingsFrom = Sheets("All Levels - Combined")
    Set shCopyTo = Sheets(14)
    '******************************************

    If sWord1 <> "" Then

        With shCopyFrom.UsedRange
            Set rUsedRange = Range(Cells(1, 1), .Cells(.Rows.Count, .Columns.Count))
        End With

        'Note this is the parent sheet and should be All Levels Combined
        'vData = Sheets(1).UsedRange.Value
        'in case usedrange doesn't start in A1
        aData() = rUsedRange.Value
        'no point having to lookup Ubound() more than once
        lRows = UBound(aData(), 1)
        lCols = UBound(aData(), 2)
        ReDim aFoundData(1 To lRows)

        'sSearch = InputBox("Enter search string")
        For lRow = 1 To lRows
            For lCol = 1 To lCols
                If InStr(1, aData(lRow, lCol), sWord1, 1) Then
                    aFoundData(lRow) = 1
                    'found a word so quit looking
                    Exit For
                ElseIf sWord2 <> "" Then
                    If InStr(1, aData(lRow, lCol), sWord2, 1) Then
                        aFoundData(lRow) = 1
                        'found a word so quit looking
                        Exit For
                    End If
                End If
            Next lCol
        Next lRow
        'For lRow = 1 To lRows
        '    If Not vFoundData(lRow) = 1 Then
        '        For lCol = 1 To UBound(vData, 2)
        '            vData(lRow, lCol) = ""
        '        Next lCol
        '    End If
        'Next lRow

        'This is where the copying takes place
        'With Sheets(14)
        '    .Select
        '    .Range(Cells(1, 1), Cells(lRows, lCols)).Select
        '    Selection = vData
        '    Selection.Sort Range("a1")
        '    .Range("a1").Select
        'End With
        'Selection.Copy
        'Sheets("Sheet1").Select
        'ActiveWindow.SmallScroll Down:=-24
        'Rows("1:1").Select
        'Application.CutCopyMode = False
        'Selection.Insert Shift:=xlDown
        'Range("A1").Select
        'Sheets("All Levels - Combined").Select
        'ActiveWindow.ScrollColumn = 20
        'ActiveWindow.ScrollColumn = 15
        'ActiveWindow.ScrollColumn = 13
        'ActiveWindow.ScrollColumn = 10
        'ActiveWindow.ScrollColumn = 6
        'ActiveWindow.ScrollColumn = 3
        'ActiveWindow.ScrollColumn = 1
        'Rows("4:4").Select
        'Selection.Copy
        'ActiveWindow.ScrollWorkbookTabs Position:=xlLast
        'Sheets("Sheet1").Select
        'Range("A1").Select
        'ActiveSheet.Paste
        'Range("A1").Select
        'Cells.Select
        'Cells.EntireColumn.AutoFit
        'Range("A1").Select

        lNextRow = lNextRow + 1
        shCopyHeadingsFrom.Rows("4:4").Copy shCopyTo.Rows(lNextRow & ":" & lNextRow)

        For lRow = 1 To lRows
            If aFoundData(lRow) = 1 Then
                lNextRow = lNextRow + 1
                shCopyFrom.Rows(lRow & ":" & lRow).Copy shCopyTo.Rows(lNextRow & ":" & lNextRow)
            End If
        Next lRow
    End If        'sWord1 <> ""
End Sub

What are your thoughts? Am I an idiot and doing this wrong? I've spent a bunch of time looking up the error codes and trying out different suggestions from the internet as I didn't want to bug you again but I thought after 4 hours of trying I'd ask you again. I'm sorry this isn't getting resolved quickly, I really do appreciate the help you've been giving me. And yes, I'm getting pretty desparate

Originally Posted by foxguy

The error
seems to be saying that the macro couldn't find the range. I would initially assume that the code was working on an empty sheet.

This file will verify that there is something on the sheet it's copying from.
I assume from your message that you were getting the form opened where it was asking for 2 Search Strings.

Wow!!! Thanks Foxguy for pulling through once again. I'm very pleased this worked!

I do have one change that I was wondering if you could help with and then this will be finished...

The question is: When searching two keywords at once, the results that are copied include any row that contains either of the two keywords entered. Can this be changed to include only those rows that contain both keywords?

If this is possible let me know. I'm not sure how or where in the code to define this, so I apologize for asking another question of you.

Other than that, the thing runs magnificently! I'm crazy happy to have had all your assistance in this and I cannot thank you enough! Thank you very much sir!

Originally Posted by foxguy

Okey Dokey

Hi again Foxguy!

I get this error when I try using the new form:
"Run-time error 9: Subscript out of range"

And then the debugger highlights this line in the userform1 code:

s = CStr(aData(lRow, lCol))

Any ideas? Is there anything I can do to make this stop? We're so close to getting this to work! Thanks again for your incredible help!

crossing my fingers

Foxguy it works!!!!!!!!!

You're amazing. Thanks a million for your excellent help with this!