Make a backup of your spreadsheet and in the backup test this code:

' - START OF CODE -
Option Explicit

Private Function lookForNext(s As String, r As Range, ws As Worksheet)
As Range
Set lookForNext = ws.Cells.Find(What:=s, After:=r,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False)
End Function

Public Sub DoUntilJohnP()

On Error GoTo DOUJP_ERR

Dim wb As Workbook
Dim wsOld As Worksheet, wsNew As Worksheet
Dim rOld As Range, rNew As Range

Set wb = ActiveWorkbook
Set wsOld = wb.ActiveSheet
Set wsNew = wb.Sheets("Sheet2")

Set rOld = wsOld.Range("A1")
Set rOld = lookForNext("ele nonrec", rOld, wsOld)
Set rNew = wsNew.Range("A1")
If Not rOld Is Nothing Then
Do Until InStr(1, rOld.Formula, "ele nonrec END") 0

rOld.Copy
Set rNew = rNew.Offset(1, 0)
rNew.PasteSpecial xlPasteAll

Set rOld = lookForNext("record sent", rOld, wsOld)
rOld.Copy
rNew.Offset(0, 8).PasteSpecial xlPasteAll

Set rOld = lookForNext("global", rOld, wsOld)
rOld.Copy
rNew.Offset(0, 23).PasteSpecial xlPasteAll

Set rOld = lookForNext("o", rOld, wsOld)
rOld.Copy
rNew.Offset(0, 29).PasteSpecial xlPasteAll

Set rOld = lookForNext("ele nonrec", rOld, wsOld)
Loop
Else
MsgBox "'ele nonrec' was not found in formulas of spreadsheet"
End If
DOUJP_GOODBYE:
Set rOld = Nothing
Set rNew = Nothing
Set wsOld = Nothing
Set wsNew = Nothing
Set wb = Nothing
Exit Sub
DOUJP_ERR:
MsgBox "NUMBER: " & Err.Number & vbCrLf & "DESCRIPTION:" & vbCrLf
& Err.Description
Resume DOUJP_GOODBYE
End Sub
' - END OF CODE -

On Feb 22, 8:07 am, JohnP wrote:
Hi,

I need the following to code to loop, but each time pasting one row further
down on Sheet 2 until the Control Find function finds "Ele NonRec END".

Cells.Find(What:="ele nonrec", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
Selection.Copy
Sheets("Sheet2").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Cells.Find(What:="record sent", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("I2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Cells.Find(What:="global", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:= _
False).Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("X2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Cells.Find(What:="o", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False) _
.Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
Range("AD2").Select
ActiveSheet.Paste
Sheets("Sheet1").Select

Please help!! Thank you in advance.

John