Need error trap

[GregR]

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

 

[Bob Phillips]

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)

 

[Barb Reinhardt]

Why not use something like this

Set frngMatch = NOTHING
On Error resume next
Set frngMatch = Cells.Find(what:=FindProj, LookIn:=xlFormulas,
lookat:=xlPart) 'Errors here if not found
On Error goto 0
If not frngMatch is nothing then
'Do what you do if it matches.

end if

HTH,
Barb Reinhardt

 

[GregR]

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)


















- Show quoted text -

Bob, that is exactly what I wanted, except now it is not looping. In
other words it does not move to the next project row in the list (iRow
=i Row +1). It finds the first project and renames it, but pulls up
the same project the second time through and fails because the name
already exists. It does not move to the next row which it should.
Probably a small glitch but can't figure it out. TIA

 

[GregR]

Why not use something like this

Set frngMatch = NOTHING
On Error resume next
Set frngMatch = Cells.Find(what:=FindProj, LookIn:=xlFormulas,
lookat:=xlPart) 'Errors here if not found
On Error goto 0
If not frngMatch is nothing then
'Do what you do if it matches.

end if

HTH,
Barb Reinhardt

















- Show quoted text -

Barb and Bob, thanks for your help. Uou nailed it, as usual.

Greg