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.


Very nice! As always, thanks Claus.

Regards,
Howard