Not sure if this is what you want

Sub Copy340WIPActiveWorkbook()
Dim WBwip As Workbook
Dim wb2 As Workbook
Dim rng As Range
Dim frngMatch As Range
Dim Cel As Range
Dim SName As String
Const sStr As String = "A2"
Dim frng As Range
Dim iRow As Long
Dim Lrow As Long
Dim Findstr As String

Set wb2 = ActiveWorkbook
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = wb2.ActiveSheet.Range("A6:A" & Lrow)

On Error Resume Next
Set WBwip = Workbooks("RF 340-000.xls")
On Error GoTo 0
If WBwip Is Nothing Then
ChDir "S:\FIN\Finance\Capital Projects\WIP Detail"
Workbooks.Open Filename:= _
"S:\FIN\Finance\Capital Projects\WIP Detail\RF 340-000.xls"
Set WBwip = Workbooks("RF 340-000.xls")
Else
'already open
End If

iRow = 5

Do Until iRow = Lrow
wb2.Activate
Range("A1").Select

FindProj = Left(ActiveCell.Offset(iRow, 0).Value, 6)

Set frng = Cells.Find(what:=FindProj, _
LookIn:=xlFormulas, _
lookat:=xlPart)
If Not frng Is Nothing Then
WBwip.Sheets("340-000-900 Pivot Table").Activate
'Findstr = frng.Offset(0, 9).Address(1, 1, xlA1)
Else
MsgBox ("Project, not found")
End If
Set frngMatch = Cells.Find(what:=FindProj, _
LookIn:=xlFormulas, _
lookat:=xlPart) 'Errors here if not
found
If Not frngMatch Is Nothing Then
frngMatch.Offset(0, 10).Select

Selection.ShowDetail = True

ActiveSheet.Move After:=wb2.Worksheets(wb2.Worksheets.Count)
ActiveWindow.Zoom = 75
ActiveSheet.Name = Left(Range(sStr), 6)
End If

iRow = iRow + 1

Loop

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

"GregR" wrote in message
ups.com...
I have this macro which does as intended, except if it does not find a
match (Line beginning with Set frngmatch..............). What I would
like is for the macro to continue looping to next project and finish
adding and renaming sheets. My code is below:

Sub Copy340WIPActiveWorkbook()
Dim WBwip As Workbook
Dim wb2 As Workbook
Dim rng As Range
Dim frngMatch As Range
Dim Cel As Range
Dim SName As String
Const sStr As String = "A2"
Dim frng As Range
Dim iRow As Long
Dim Lrow As Long
Dim Findstr As String

Set wb2 = ActiveWorkbook
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = wb2.ActiveSheet.Range("A6:A" & Lrow)

On Error Resume Next
Set WBwip = Workbooks("RF 340-000.xls")
On Error GoTo 0
If WBwip Is Nothing Then
ChDir "S:\FIN\Finance\Capital Projects\WIP Detail"
Workbooks.Open filename:= _
"S:\FIN\Finance\Capital Projects\WIP Detail\RF 340-000.xls"
Set WBwip = Workbooks("RF 340-000.xls")
Else
'already open
End If

iRow = 5

Do Until iRow = Lrow
wb2.Activate
Range("A1").Select

FindProj = Left(ActiveCell.Offset(iRow, 0).Value, 6)

Set frng = Cells.Find(what:=FindProj, LookIn:=xlFormulas,
lookat:=xlPart)
If Not frng Is Nothing Then
WBwip.Sheets("340-000-900 Pivot Table").Activate
'Findstr = frng.Offset(0, 9).Address(1, 1, xlA1)
Else
MsgBox ("Project, not found")
End If
Set frngMatch = Cells.Find(what:=FindProj, LookIn:=xlFormulas,
lookat:=xlPart) 'Errors here if not found
frngMatch.Activate
ActiveCell.Offset(0, 10).Select

Selection.ShowDetail = True

ActiveSheet.Move After:=wb2.Worksheets(wb2.Worksheets.Count)
ActiveWindow.Zoom = 75
ActiveSheet.Name = Left(Range(sStr), 6)

iRow = iRow + 1

Loop

Application.DisplayAlerts = True

End Sub

Thanks, Greg