Making a macro loop

I have a macro which identifies a place using a key text ('BX') in the document , and the next one below it. It establishes two placeholders ('First' and 'Next') , and then deletes the text between.

The only problem is it only works for the first instance of the key text , but then stops.

Can someone suggest a way to modify it so it runs through to the bottom of the document and finds all examples , and not just the first?

Sub Macro8()
'
' Macro8 Macro
'
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "BX"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute
    Selection.EndKey Unit:=wdLine
    Selection.TypeText Text:="First"
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "BX"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute
    Selection.HomeKey Unit:=wdLine
    Selection.MoveUp Unit:=wdLine, Count:=1
    Selection.TypeText Text:="Next"
    Selection.MoveUp Unit:=wdScreen, Count:=8
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "First*Next"
        .Replacement.Text = "^p^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Grateful for any advice.

It's not apparent what you mean about the 'BX', since there's nothing like that in your 'Before' document. In any event, if the aim is to delete the two 'BX' markers and everything in between, that could be done with a wildcard Find/Replace, where:
Find = BX*BX
Replace = nothing

Hi macropod - thanks for getting back. Sorry if the aim here is not clear.

The lines containing 'BX' are catalogue numbers and need to be maintained in their entirety , as well as the Item Description that goes with each.

EG

BEATLES - ABBEY ROAD
235698BX10


With my macro I'm trying to delete extraneous text between.

So , for example

ABBA - KNOWING ME KNOWING YOU
148875BX103

Text to delete1

CA VA CA VA - WHERE`S ROMEO
148653BX21

Text to delete2

MATCHBOX - MIDNITE DYNAMOS
146020BX150

Text to delete3

ROXETTE - DRESSED FOR SUCCESS
103922BX130

Text to delete4

would become

ABBA - KNOWING ME KNOWING YOU PRONG
148875BX103

CA VA CA VA - WHERE`S ROMEO
148653BX21

MATCHBOX - MIDNITE DYNAMOS
146020BX150

ROXETTE - DRESSED FOR SUCCESS
103922BX130


The macro I posted deals with the first instance successfully , but then stops there. I was wanting it to go through and remove each example of unwanted text.

In essence I'm doing this in the macro ;

1. Find the first instance of 'BX' in the catalogue number. Move cursor to the end and enter the word 'First'

2. Find the next instance of 'BX' and move the cursor to the beginning of the line and up one line. Enter the word 'Next'. This puts 'First' at the end of the first Catalogue Number and 'Next' at the beginning of the next Item Description , ready to delete whatever text is between.

3. Replace everything between 'First and 'Next' with two paragraph returns.

I'd like at that point for the macro to continue to the next instance and delete superfluous text until only the Catalogue Numbers and Item Descriptions remain.

I wondered if placing some 'Stop' text at the bottom of the document would cause the macro to finish at that point. Otherwise , it might not know when to stop as each list varies in length.

I updated the sample files , so hopefully they will be more helpful.

Inn which case you could use a macro like:

Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "BX*BX"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
  End With
  Do While .Find.Execute
    .Start = .Paragraphs.First.Range.End
    .End = .Paragraphs.Last.Previous.Range.Start
    .Delete
    .Collapse wdCollapseEnd
  Loop
  With .Find
    .Text = "BX"
  End With
  Do While .Find.Execute
    .Start = .Paragraphs.First.Range.End
    .End = ActiveDocument.Range.End
    .Delete
    .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
End Sub

Thanks macropod. I'll give it a go.

Even faster - with no loops:

Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Format = False
    .Forward = True
    .Text = "[ ]@^13"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "(X[0-9]@^13{2})*([!^13]@^13[!^13][0-9]@B)"
    .Replacement.Text = "\1\2"
    .Execute Replace:=wdReplaceAll
    .Wrap = wdFindStop
    .Forward = False
    .Text = "(BX[0-9]@)^13{2}[!^13]@^13"
    .Replacement.Text = "\1"
    .Execute Replace:=wdReplaceOne
  End With
End With
Application.ScreenUpdating = True
End Sub

Brilliantly done , macropod.