Error using .Find across worksheets

[Kid_Icarus]

I am trying to loop though all worksheets in a book, search for a cell containing specific text and then copy all rows below that cell into a newly created sheet. Despite two days of internet searching I cannot resolve an error message I receive 'Object variable or With Variable not set' with the following code. Any help gratefully received; firstly to point out my obvious mistake and secondly to help me make the code more efficient and correct.

[vba]
Sub LoopThroughSheets()

Dim ws As Worksheet
Dim x As Range

'Turn off updates & messages
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Check for earlier version and delete if it exists
On Error Resume Next
Set ws = Sheets("MS_Report")
On Error GoTo 0
If Not ws Is Nothing Then
Sheets("MS_Report").Delete
Else
End If

'Create New Consolidated sheet
Sheets.Add.Name = "MS_Report"

'Sheet run-thru loop
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Cells.Select
Cells.Find(What:="Milestones and deliverables due next period and later if at risk", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
If Not x Is Nothing Then
'Offset
ActiveCell.Offset(3, 0).Select
'Highlight row
ActiveCell.EntireRow.Select
'Expand down to bottom of table
Range(Selection, Selection.End(xlDown)).Select
'Copy Rage
Selection.Copy
'Move to New Sheet
Sheets("MS_Report").Select
ActiveSheet.Paste
Else
GoTo NextSheet
End If
NextSheet:
Next ws

'Turn on updates & messages
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
[/vba]

[Opv]

You don't need to use Select to achieve what you want to do. Try something like the following:

[VBA]
Sub LoopThroughSheets()

Dim ws As Worksheet
Dim x, y As Range

'Turn off updates & messages
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Check for earlier version and delete if it exists
On Error Resume Next
Set ws = Sheets("MS_Report")
On Error GoTo 0
If Not ws Is Nothing Then
Sheets("MS_Report").Delete
Else
End If

'Create New Consolidated sheet
Sheets.Add.Name = "MS_Report"

'Sheet run-thru loop
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Set x = Cells.Find(What:="Milestones and deliverables due next period and later if at risk")
If Not x Is Nothing Then
'Offset
Set y = Range(x.Offset(3, 0).Address, Range(x.Offset(3, 0).Address).End(xlDown)).EntireRow

'Copy info to New Sheet
y.EntireRow.Copy
Sheets("MS_Report").Rows(2).Insert shift:=xlDown
Else
GoTo NextSheet
End If
Next ws

'Turn on updates & messages
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
[/VBA]

[Opv]

Here is an updated version:

[VBA]
Sub LoopThroughSheets()

Dim ws As Worksheet
Dim x, y As Range

'Turn off updates & messages
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Check for earlier version and delete if it exists
On Error Resume Next
Set ws = Sheets("MS_Report")
On Error GoTo 0
If Not ws Is Nothing Then
Sheets("MS_Report").Delete
Else
End If

'Create New Consolidated sheet
Sheets.Add.Name = "MS_Report"

'Sheet run-thru loop
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Set x = Cells.Find(What:="Milestones and deliverables due next period and later if at risk")
If Not x Is Nothing Then
'Offset
Set y = Range(x.Offset(3, 0).Address, Range(x.Offset(3, 0).Address).End(xlDown)).EntireRow

'Move to New Sheet
y.EntireRow.Copy
Sheets("MS_Report").Rows(2).Insert shift:=xlDown
End If

Next ws

Application.CutCopyMode = False
Sheets("MS_Report").Activate


'Turn on updates & messages
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
[/VBA]

[Kid_Icarus]

Thanks OPV. I took your first version and it worked straight away, but since then I've been tinkering and learnt a lot of new things.

It was interesting how you used insert rather than paste so that you could use the function to shift the cells down rather than adding a few lines of code to always go to the last clear row. My current task is to understand 'insert' and see if you can copy formatting also.

Thanks again!

[Opv]

Thanks OPV. I took your first version and it worked straight away, but since then I've been tinkering and learnt a lot of new things.

It was interesting how you used insert rather than paste so that you could use the function to shift the cells down rather than adding a few lines of code to always go to the last clear row. My current task is to understand 'insert' and see if you can copy formatting also.

Thanks again!

You might want to consider changing:

[vba]
For Each ws In ActiveWorkbook.Worksheets
[/vba]
to this:

[vba]
For Each ws In ThisWorkbook.Worksheets
[/vba]
When you use ActiveWorkbook, your code is going to loop through the worksheets of the workbook that is active at the time the code is run.

I'm glad the code worked for you.