I have this code which works fine for the first loop. It does as
expected, adds a detail sheet that matches the project found in wb2 at
Range("A6"). The second time through it adds the same project from "A6"
and not "A7". Can someone help with the code. TIA

Sub Copy340WIP()
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 = Workbooks("Projects Test.xls")
Set rng = wb2.Sheets("Projects").Range("A6:A24")
Lrow = Cells(Rows.Count, 1).End(xlUp).Row

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"
Else
'already open
End If
wb2.Activate
Range("A1").Select


Do
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) '.Address
frngMatch.Activate
ActiveCell.Offset(0, 9).Select
Selection.ShowDetail = True

ActiveSheet.Move after:=wb2.Worksheets(wb2.Worksheets.Count)
ActiveSheet.Name = Left(Range(sStr), 6)

iRow = iRow + 1

Loop Until iRow = wb2.ActiveSheet.UsedRange.Rows.Count

Application.DisplayAlerts = True

End Sub

Function Findstr(FindProj As String) As String
Dim frng As Range
Dim Cel As Range
Dim P As String
Dim iRow As Integer
Dim WBPrj As Workbook
Dim WBwip As Workbook
Set WBPrj = Workbooks("Project Test.xls")
Set WBwip = Workbooks("RF 340-000.xls")

WBPrj.Activate
Range("A1").Select
iRow = 5
FindProj = Left(ActiveCell.Offset(iRow, 0).Value, 6)
'Enter code here to place this value "FindProj" wherever you want it
'Example: Range("B7").Value = FindProj
'FindProj = InputBox("Enter Project Number, such as 00-000", "Enter
Project Number", "06-012")
'FindProj = Left(Cel(P), 6).Value

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
Findstr.Offset(0, 9).Activate

End Function

Greg