I dug this out of my archives, modified it slightly for a Poster.

Using XX and XXX as "key words" multiple times in column A, it does pretty well. Grabs the ranges from the Start Key word to the End Key word (including the Start and End words), puts them in column B, clears column A and returns the data from column B back to column A.

The end result in column A is accurate, however, it is in reverse order of how it was originally listed in A. Would prefer it to be in same order as original.

Another preference would be to only take the data BETWEEN the start and end words and when copied to column B, a blank cell would be between each range.

I'm pretty sure I can just go to column B and remove the start and end words with extra code before bringing column B back to A. Was wondering if it makes better sense to just offset from start word one cell down and from end word one cell up and move that range segment to B, perhaps with an offset(1, 0) to produce the blank between each range in column B.

But I can't figure how to exclude the start and end words.

Any suggestions?
Thanks,
Howard

Option Explicit

Sub Copy_Twixt_Keywords()

Dim rngKeyWordStart As Range, rngKeyWordEnd As Range
Dim strKeyWordStart As String, strKeyWordEnd As String, FirstFound As String

'strKeyWordStart = Range("K1").Value
strKeyWordStart = "XX"

'strKeyWordEnd = Range("K2").Value
strKeyWordEnd = "XXX"

Application.ScreenUpdating = False
With Sheets("Sheet1")
Set rngKeyWordStart = .Range("A:A").Find(What:=strKeyWordStart, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not rngKeyWordStart Is Nothing Then

FirstFound = rngKeyWordStart.Address

Set rngKeyWordEnd = .Range("A:A").Find(What:=strKeyWordEnd, _
After:=rngKeyWordStart)

If Not rngKeyWordEnd Is Nothing Then
Do
.Range(rngKeyWordStart, rngKeyWordEnd).Copy
Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).PasteSpecial xlPasteValues

Set rngKeyWordStart = .Range("A:A").Find(What:=strKeyWordStart, _
After:=rngKeyWordEnd)
Set rngKeyWordEnd = .Range("A:A").Find(What:=strKeyWordEnd, _
After:=rngKeyWordStart)

Loop While rngKeyWordStart.Address < FirstFound And _
rngKeyWordEnd.Row rngKeyWordStart.Row
Else
MsgBox "Cannot find a match for the 'End' keyword: " & _
vbLf & """" & strKeyWordEnd & """", _
vbExclamation, "No Match Found"
End If

Else
MsgBox "Cannot find a match for the 'Start' keyword: " & _
vbLf & """" & strKeyWordStart & """", _
vbExclamation, "No Match Found"
End If

End With

Application.CutCopyMode = True
Application.ScreenUpdating = True

Range("A:A").ClearContents
Range("B:B").Copy Range("A1")
Range("B:B").ClearContents
End Sub