Hi Howard,

Am Tue, 27 Aug 2013 01:24:26 -0700 (PDT) schrieb Howard:

Drat, that did not post up very well.

never mind.
Try:
Sub Test2()
Dim strStart As String
Dim strEnd As String
Dim RStart As Range
Dim REnd As Range
Dim LRow As Long
Dim i As Long

strStart = "XX"
strEnd = "XXX"
i = 1

LRow = Cells(Rows.Count, 1).End(xlUp).Row
Do
Set RStart = Range(Cells(i, 1), Cells(LRow, 1)).Find _
(strStart, Cells(LRow, 1), xlValues, xlWhole)
If Not RStart Is Nothing Then
Set REnd = Range(Cells(i, 1), Cells(LRow, 1)).Find _
(strEnd, Cells(RStart.Row, 1), xlValues, xlWhole)
Range(RStart.Offset(1, 0), REnd.Offset(-1, 0)).Copy
Range("B" & Rows.Count).End(xlUp).Offset(2, 0) _
.PasteSpecial xlPasteValues
i = REnd.Row
End If
Loop While i < LRow And Not RStart Is Nothing
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2