Search a worksheet for a cell value, then copy the adjacent cells into a variable range

Question

I have several Excel workbooks with each workbook containing multiple sheets.

I do a keyword search across all worksheets using a particular value ("James Smith"). If the value is found, then I need to offset five columns over from that cell location (i.e. the "found cell" which will always be in Column C somewhere so the offset is pointing to column H) and then select/copy the adjacent rows into a range that will ultimately be pasted into a new worksheet "masterSheet".

The problems are:

1. The cell address in each of these sheets will vary so that the cell address is not the same in each worksheet
2. I get errors when I try to set the FoundRange value below.

    'Search multiple workbooks, look only for sheetnames that begin with "Week of" and don't contain the word "old"
    
    If currentSheet.Name Like "*Week of*" And InStr(currentSheet.Name, "Old") = 0 Then
        'If currentSheet.Name Like "*Week of*" Then
                
        'Within the current sheet look for a cell that contains "James Smith"
        With currentSheet
                
            .Range("C:C").Columns.Select
                
            Set FoundCell = Selection.Find(What:="James Smith", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
              MatchCase:=False, SearchFormat:=False)
                
            'When "James Smith" is found in the current worksheet, get the cell address and offset from that cell location"
            OffsetCell = currentSheet.Range(FoundCell.Address).Offset(0, 5).Address
    
            'In Column "H" select the adjacent non-blank cells and copy into a range <line below where I define "FoundRange" is where I keep getting the "runtime error 424 object required error"
            Set FoundRange = Range(OffsetCell, OffsetCell.End(xlDown))

            For Each cell In currentSheet.Range(FoundRange)
                If Not IsEmpty(cell) Then
                    currentSheet.Range(cell.Address).Copy
                    masterSheet.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    masterSheet.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Format(CDate(Replace(Replace(currentSheet.Name, "Week of ", " "), ".", "/")), "mm/dd/yyyy")
                    masterSheet.Range("C" & Rows.Count).End(xlUp).Offset(0, -1) = "James Bradford"
                    currentSheet.Range(cell.Address).Offset(0, 1).Copy
                    masterSheet.Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    currentSheet.Range(cell.Address).Offset(0, 2).Copy
                    masterSheet.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    currentSheet.Range(cell.Address).Offset(0, 3).Copy
                    masterSheet.Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next              
        End With
    End If

Answer 1

This works. FYI... You have James Smith in the find and James Bradford in the loop. I added a mastersheet for testing, so get rid of the "Set masterSheet" line.

Sub RngTest()
'Search multiple workbooks, look only for sheetnames that begin with "Week of" and don't contain the word "old"

Set currentSheet = ActiveSheet
Set masterSheet = ActiveWorkbook.Sheets("MasterSheet")
If currentSheet.Name Like "*Week of*" And InStr(currentSheet.Name, "Old") = 0 Then
    'If currentSheet.Name Like "*Week of*" Then

        'Within the current sheet look for a cell that contains "James Smith"
        With currentSheet

        .Range("C:C").Columns.Select

        Set FoundCell = Selection.Find(What:="James Smith", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        'When "James Smith" is found in the current worksheet, get the cell address and offset from that cell location"
        Set OffsetCell = currentSheet.Range(FoundCell.Address).Offset(0, 5)

         'In Column "H" select the adjacent non-blank cells and copy into a range <line below where I define "FoundRange" is where I keep getting the "runtime error 424 object required error"
         Set FoundRange = Range(OffsetCell, OffsetCell.End(xlDown))

                 For Each cell In FoundRange.Cells
                    If Not IsEmpty(cell) Then
                        currentSheet.Range(cell.Address).Copy
                        masterSheet.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                        masterSheet.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Format(CDate(Replace(Replace(currentSheet.Name, "Week of ", " "), ".", "/")), "mm/dd/yyyy")
                        masterSheet.Range("C" & Rows.Count).End(xlUp).Offset(0, -1) = "James Bradford"
                        currentSheet.Range(cell.Address).Offset(0, 1).Copy
                        masterSheet.Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                        currentSheet.Range(cell.Address).Offset(0, 2).Copy
                        masterSheet.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                        currentSheet.Range(cell.Address).Offset(0, 3).Copy
                        masterSheet.Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    End If
                Next


        End With

    End If

End Sub