Excellent! Thank You very much. The code is perfect and it runs very fast.
I added two things (below) I found that if there was an empty paragraph at the end of the list, the code wouldn't run, so I added some code to delete an empty paragraph mark, if there is one, and second, I added a line to move the cursor to the beginning of the file before running the rest of the code.
Thanks again!
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String
With ActiveDocument
' the code below deletes the last paragraph mark at the end of the doc
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p^p"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
With Selection
If .Find.Forward = True Then
.Collapse Direction:=wdCollapseStart
Else
.Collapse Direction:=wdCollapseEnd
End If
.Find.Execute Replace:=wdReplaceOne
If .Find.Forward = True Then
.Collapse Direction:=wdCollapseEnd
Else
.Collapse Direction:=wdCollapseStart
End If
.Find.Execute
End With
' the code above deletes the last paragraph mark at the end of the doc
' move to the beginning of the document
Selection.HomeKey Unit:=wdStory
For i = .Paragraphs.Count To 1 Step -1
StrFnd = .Paragraphs(i).Range.Text
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = StrFnd
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindContinue
.MatchAllWordForms = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
End With
.Range.InsertAfter StrFnd
Next
End With
Application.ScreenUpdating = True
End Sub