Kid_Icarus
05-30-2012, 08:24 AM
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.
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
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