Searching cells for keyword and moving row to new sheet

Hi,I'm trying to workout how to do the following:1. search the activesheet column G for a keyword that i enter into an input box. 2. when a cell is found containinig that word i then want to select the row and move a copyt into a new sheet.3. repeat the process until all rows have been searched and a new sheet contains all those that matched4. on the new sheet compare the cell in the column containing the keyword and the cell to the left, if they don't both contain the keyword then highlight both cells in yellow.I've attached an example of what the initial sheet would look like and have struggled to find anything close to what i want to do.Thanks in advance for any help you can provide.

Re: Searching cells for keyword and moving row to new sheet

Quote from Mumps;682314

Hi Daren. Try:

Code

Option Compare Text
Sub Copydata()
    Application.ScreenUpdating = False
    Dim bottomG1 As Integer
    bottomG1 = Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp).Row
    Dim bottomG2 As Integer
    Dim rng1 As Range
    Dim rng2 As Range
    Dim foundVal As String
    foundVal = InputBox("Please enter the word to find.")
    For Each rng1 In Sheets("Sheet1").Range("G2:G" & bottomG1)
        If rng1 Like "*" & foundVal & "*" Then
            rng1.EntireRow.Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next rng1
    bottomG2 = Sheets("Sheet2").Range("G" & Rows.Count).End(xlUp).Row
    For Each rng2 In Sheets("Sheet2").Range("G2:G" & bottomG2)
        If Not rng2 Like "*" & rng2.Offset(0, -1) & "*" Then
           rng2.Interior.ColorIndex = 6
           rng2.Offset(0, -1).Interior.ColorIndex = 6
        End If
    Next rng2
    Application.ScreenUpdating = True
End Sub

Display More

Thanks that works really well and makes sense. What if I want to create a sheet with the foundval name? But only create the sheet it if it exists already otherwise update the existing sheet?

Re: Searching cells for keyword and moving row to new sheet

Quote from Mumps;682432

Try:

Code

Option Compare Text
Sub Copydata()
    Application.ScreenUpdating = False
    Dim bottomG1 As Integer
    bottomG1 = Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp).Row
    Dim bottomG2 As Integer
    Dim rng1 As Range
    Dim rng2 As Range
    Dim foundVal As String
    Dim ws As Worksheet
    Set ws = Nothing
    foundVal = InputBox("Please enter the word to find.")
    For Each rng1 In Sheets("Sheet1").Range("G2:G" & bottomG1)
        If rng1 Like "*" & foundVal & "*" Then
            On Error Resume Next
            Set ws = Worksheets(foundVal)
            On Error GoTo 0
            If ws Is Nothing Then
                Worksheets.Add(After:=Sheets(Sheets.Count)).Name = foundVal
            End If
            rng1.EntireRow.Copy ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next rng1
    bottomG2 = ActiveSheet.Range("G" & Rows.Count).End(xlUp).Row
    For Each rng2 In ActiveSheet.Range("G2:G" & bottomG2)
        If Not rng2 Like "*" & rng2.Offset(0, -1) & "*" Then
            rng2.Interior.ColorIndex = 6
            rng2.Offset(0, -1).Interior.ColorIndex = 6
        End If
    Next rng2
    Application.ScreenUpdating = True
End Sub

Display More

Thanks Mumps, that works great. The idea of not creating a new sheet if it exists is so that if i use the same workbook with new data, it can add new rows to the existing sheet if i use the same foundval. How do I get it to carry out that task. Currently if I repeat the process and use the same foundval, it just highlights the columns w and v on sheet1.

Re: Searching cells for keyword and moving row to new sheet

Hi Mumps, I added an additional line to select the existing sheet if it already exists.

Option Compare Text
Sub Copydata()
    Application.ScreenUpdating = False
    Dim bottomG1 As Integer
    bottomG1 = Sheets("Sheet1").Range("G" & Rows.Count).End(xlUp).Row
    Dim bottomG2 As Integer
    Dim rng1 As Range
    Dim rng2 As Range
    Dim foundVal As String
    Dim ws As Worksheet
    Set ws = Nothing
    foundVal = InputBox("Please enter the word to find.")
    For Each rng1 In Sheets("Sheet1").Range("G2:G" & bottomG1)
        If rng1 Like "*" & foundVal & "*" Then
            On Error Resume Next
            Set ws = Worksheets(foundVal)
            On Error GoTo 0
            If ws Is Nothing Then
                Worksheets.Add(After:=Sheets(Sheets.Count)).Name = foundVal
            End If
            ws.Select
            rng1.EntireRow.Copy ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next rng1
    bottomG2 = ActiveSheet.Range("G" & Rows.Count).End(xlUp).Row
    For Each rng2 In ActiveSheet.Range("G2:G" & bottomG2)
        If Not rng2 Like "*" & rng2.Offset(0, -1) & "*" Then
            rng2.Interior.ColorIndex = 6
            rng2.Offset(0, -1).Interior.ColorIndex = 6
        End If
    Next rng2
    Application.ScreenUpdating = True
End Sub

Thanks for your help with this, I'm a very happy man...