Cull rows based on searching for text in a column.

Pat,

Welcome to the forum!
Give this macro a try:

Sub tgr()
    
    Dim ws As Worksheet
    Dim wsNew As Worksheet
    Dim rngFound As Range
    Dim rngCut As Range
    Dim strFirst As String
    Dim strFind As String
    Dim lCalc As XlCalculation
    
    strFind = Trim(InputBox("Type the word or phrase to search for" & Chr(10) & "Use the * symbol to search for partial matches", "Collect Results", "White"))
    If Len(strFind) = 0 Then Exit Sub
    
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    With ActiveWorkbook
        Set wsNew = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    End With
    
    For Each ws In ActiveWorkbook.Sheets
        If ws.Name <> wsNew.Name Then
            Set rngFound = ws.Columns("B").Find(strFind, ws.Cells(ws.Rows.Count, "B"), xlValues, xlWhole)
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                Set rngCut = rngFound
                Do
                    Set rngCut = Union(rngCut, rngFound)
                    Set rngFound = ws.Columns("B").Find(strFind, rngFound, xlValues, xlWhole)
                Loop While rngFound.Address <> strFirst
                rngCut.EntireRow.Copy wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Offset(1)
                rngCut.Clear
                Set rngCut = Nothing
                Set rngFound = Nothing
                strFirst = vbNullString
            End If
        End If
    Next ws
    
    Set ws = Nothing
    Set wsNew = Nothing
    strFind = vbNullString
    
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub

How to use a macro:

1. Make a copy of the workbook the macro will be run on
   • Always run new code on a workbook copy, just in case the code doesn't run smoothly
   • This is especially true of any code that deletes anything
2. In the copied workbook, press ALT+F11 to open the Visual Basic Editor
3. Insert | Module
4. Copy the provided code and paste into the module
5. Close the Visual Basic Editor
6. In Excel, press ALT+F8 to bring up the list of available macros to run
7. Double-click the desired macro (I named this one tgr)

Sorry tigeravatar I did not see your post - this may be another option. Sorry about that tigeravatar as I don't like over posting other contributors.

the rest of the row information in that row is copied to a brand new spreadsheet.

So you do not copy the entire row just everything from column C to end of the row - are the rows fixed width or do they vary. It is not hard to iterate through the entire workbook and check every sheet for a keyword and then copy the data across to a new worksheet. If you could just upload a sample workbook just showing how the data is set out, where the value/word will occur (which column) and what data is copied across to new worksheet - like a before and after - only need a few entries just so can see how the data is set out. Depending on your VBA skills you could modify something like the following (this searches Column B). I have not tested this code - I have just modified it from previous project. As I say a sample worksheet would help

Sub findRetire()
Dim myVar, myRange As Range, rn As Range, wNew As Worksheet, ws As Worksheet
   On Error GoTo find_Error
    myVar = InputBox(Prompt:="Enter values to move.", _
          Title:="Enter Keyword", Default:="Keyword")
If myVar = "" Or myVar = "Keyword" Then
MsgBox "No value selected"
Exit Sub
End If
Sheets.Add After:=Sheets(Sheets.Count)
Set wNew = ActiveSheet: wNew.Name = "SummarySheet" & format(now,"ddmmyyhhss")
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> wNew.Name Then
'Change the next line to the column where the keyword should be
Set myRange = Find_Range(myVar, ws.Columns("B"), xlValues, xlWhole)
If Not myRange Is Nothing Then
For Each rn In myRange
'if the entire row has to be copied to summary worksheet change next line to ws.rows(rn.row).copy
ws.rn.Resize(, ws.Cells(rn.Row, Columns.Count).End(xlToLeft).Column).Copy
'places copied row into summary sheet at next available row
wNew.Range("A" & wNew.Cells(Rows.Count, "A").End(xlUp).Row+).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'next line clears the row that contained the value
ws.rn.Resize(, ws.Cells(rn.Row, Columns.Count).End(xlToLeft).Column).ClearContents
Next
End If
End If
Next

Application.ScreenUpdating = True
   On Error GoTo 0
   Exit Sub
find_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure findLOJA of Module1"
End Sub

'Nothing in the rest of the code needs to be changed
Function Find_Range(Find_Item As Variant, _
    Search_Range As Range, _
    Optional LookIn As Variant, _
    Optional LookAt As Variant, _
    Optional MatchCase As Boolean) As Range
     
    Dim c As Range
    If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
    If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
    If IsMissing(MatchCase) Then MatchCase = False
     
    With Search_Range
        Set c = .Find( _
        What:=Find_Item, _
        LookIn:=LookIn, _
        LookAt:=LookAt, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=MatchCase, _
        SearchFormat:=False)
        If Not c Is Nothing Then
            Set Find_Range = c
            firstAddress = c.Address
            Do
                Set Find_Range = Union(Find_Range, c)
                Set c = .FindNext(c)
            Loop While c.Address <> firstAddress
        End If
    End With
     
End Function

Depending on your VBA skill level you could modify this. Add this to a module and change the values I have marked

pthielan,

I deleted the original contents because you used the word "Cull" which meant to me that you wanted to move the items to a new sheet and delete them from their original locations. If that is not the case, you just need to delete this line in the macro so that the items do not get deleted from their original locations:

                rngCut.Clear

[EDIT]
@smuzoen, no worries about posting here. The more solutions, the better I say

Sorry - my code was not tested - glad tigeravatar's code worked. For what it is worth (now tested)

Sub findRetire()
Dim myVar, myRange As Range, rn As Range, wNew As Worksheet, ws As Worksheet
   On Error GoTo find_Error
    myVar = InputBox(Prompt:="Enter values to move.", _
          Title:="Enter Keyword", Default:="Keyword")
If myVar = "" Or myVar = "Keyword" Then
MsgBox "No value selected"
Exit Sub
End If
Sheets.Add After:=Sheets(Sheets.Count)
Set wNew = ActiveSheet: wNew.Name = "SummarySheet" & Format(Now, "ddmmyyhhss")
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> wNew.Name Then
'Change the next line to the column where the keyword should be
Set myRange = Find_Range(myVar, ws.Columns("A"), xlValues, xlWhole)
If Not myRange Is Nothing Then
For Each rn In myRange
'if the entire row has to be copied to summary worksheet change next line to ws.rows(rn.row).copy
rn.Resize(, ws.Cells(rn.Row, Columns.Count).End(xlToLeft).Column).Copy
'places copied row into summary sheet at next available row
wNew.Range("A" & wNew.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Next
End If
End If
Next

Application.ScreenUpdating = True
   On Error GoTo 0
   Exit Sub
find_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure findLOJA of Module1"
End Sub

'Nothing in the rest of the code needs to be changed
Function Find_Range(Find_Item As Variant, _
    Search_Range As Range, _
    Optional LookIn As Variant, _
    Optional LookAt As Variant, _
    Optional MatchCase As Boolean) As Range
     
    Dim c As Range
    If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
    If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
    If IsMissing(MatchCase) Then MatchCase = False
     
    With Search_Range
        Set c = .Find( _
        What:=Find_Item, _
        LookIn:=LookIn, _
        LookAt:=LookAt, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=MatchCase, _
        SearchFormat:=False)
        If Not c Is Nothing Then
            Set Find_Range = c
            firstAddress = c.Address
            Do
                Set Find_Range = Union(Find_Range, c)
                Set c = .FindNext(c)
            Loop While c.Address <> firstAddress
        End If
    End With
     
End Function