Search document for rows containing a specific word, cut/paste into new sheet

I am attempting to sort data on a very large report, but I am very inexperienced with the use of VBA.

In sheet 1 of this report are several columns of data. What I am looking to do is get a macro that will search for a specific word in either column A OR column F, then cut/paste the entire row containing that word onto sheet 2 and remove the blank row.

Things to consider:

1. Columns A and F will contain other information than just the word I am looking for.
2. There may be, at times, a blank cell in column F
3. The report is almost 7000 rows.
4. The word may appear in BOTH column A AND column F in some rows.
5. The word may appear with both capital and lower-case letters

For instance, I may want to take any row containing the word "diagnosis" and cut/paste that entire row onto sheet 2. The word "diagnosis" may appear in 100 different rows and may appear in the same row more than once. The word "diagnosis" may also appear as "Diagnosis" or "DIAGNOSIS".

I'm not sure if I left anything out. I appreciate any help that anyone can provide. If there are any additional concerns, please let me know and I will respond ASAP. Thanks again.

mea02300,

Give this a try:

Sub tgr()
    
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rngFound As Range
    Dim rngCopy As Range
    Dim strFirst As String
    Dim strFind As String
    
    strFind = InputBox("Enter the keyword to be searched for in columns A and F:", "Find Text")
    If Len(strFind) = 0 Then Exit Sub   'Pressed cancel
    
    Set wsData = Sheets(1)
    Set wsDest = Sheets(2)
    
    Set rngFound = wsData.Range("A:A,F:F").Find(strFind, , xlValues, xlPart)
    If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Set rngCopy = rngFound.EntireRow
        Do
            Set rngCopy = Union(rngCopy, rngFound.EntireRow)
            Set rngFound = wsData.Range("A:A,F:F").Find(strFind, rngFound, xlValues, xlPart)
        Loop While rngFound.Address <> strFirst
        rngCopy.EntireRow.Copy wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        rngCopy.EntireRow.Delete xlShiftUp
    End If
    
    Set wsData = Nothing
    Set wsDest = Nothing
    Set rngFound = Nothing
    Set rngCopy = Nothing
    
End Sub

Originally Posted by stnkynts

Note: You might want to pull the Msgbox out of tigeravatar's code. It was there for testing purposes im sure.

Thanks for spotting that! I forgot to delete it out. You are quite right, it was there for testing