Copy & paste rows after found text to different wb and delete them

[goaljohnbill]

I have a table as follows

Animal ID Tube # PRVg1 Result date
2008019881 55717 0.86 Neg 6/17/2008
2008019881 55718 0.999 Neg 6/17/2008
2008019881 55719 0.986 Pos! 6/17/2008
2008019881 55719 0.986 Neg 6/17/2008
2008019881 55720 0.929 Neg 6/17/2008
2008019881 55721 0.951 Neg 6/17/2008
2008019881 55722 0.96 Pos! 6/17/2008
2008019881 55722 0.96 Neg 6/17/2008
2008019881 55723 0.985 Neg 6/17/2008
2008019881 55724 0.983 Neg 6/17/2008

I need to be able to find each 1st Pos! result, go to the next record
in line (the dup tube number) copy that to a different wb, and delete
the copied line. I attemped to modify code greg wilson posted much
earlier to do so as follows. Somthing is wrong in the loop construct,
it wont end because it appears to "stay on" the second value, there
are possibly other errors after that also (such as the union):

Set MyRange = Selection
With MyRange
Set P = .find(What:="Pos!", LookIn:=xlValues, LookAt:=xlWhole,
_
SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False)
'''''
' 1st pos is "marked" to show loop stop point
'''''
If Not P Is Nothing Then
FirstAddress = P.Address
'''''
' set range ref to cell for union to create list
'''''
P.Select
ActiveCell.Offset(1, 0).Select
Set DeleteRng = ActiveCell
'''''
' activate row, CnP to rt list
'''''
ActiveCell.EntireRow.Select
Selection.Copy
Windows("i_PRVRT daily.xls").Activate
Range("A65515").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Windows("b_PRVAllPaste daily.xls").Activate
'''''
' setting p2 as find next p allows loop and
movement down from next pos!
' union builds list of ranges loops while there
are records
' that havnt already been checked
'''''
Do
Set P2 = .FindNext(P)
SecondAddress = P2.Address
If SecondAddress <> FirstAddress Then
P2.Select
ActiveCell.Offset(1, 0).Select
Set DeleteRng = Union(DeleteRng, P2, P)
ActiveCell.EntireRow.Select
Selection.Copy
Windows("i_PRVRT daily.xls").Activate
Range("A65515").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Windows("b_PRVAllPaste daily.xls").Activate
Else
End If
Loop While Not P2 Is Nothing And P2.Address <>
FirstAddress
End If
End With
'''''
' deletes rows of all records from union list
' saves and closes correct files
'''''
DeleteRng.EntireRow.Delete

Also I realized while messing with this that the find value Pos! could
also occur in the duplicate record and I wouldnt want it treated the
same, is there some way to "redraw" the range so that it would start
after the previous copied record to be erased?

thanks
john

 

[goaljohnbill]

A thought just occurred to me that i will work on... could i do a For
Each to the ranges in "DeleteRng" to do all of the record manipulation
after finding all of the Pos! records?

 

[goaljohnbill]

This appears it will work sorry to bother

john