Not very elegant but try this:


Sub MacroFindAndDeleteAllButFirst1()
Dim Word
Dim Page
CurrentPage = Selection.Information(wdActiveEndPageNumber)

Selection.HomeKey Unit:=wdStory
Page = InputBox("What Page is it on?", "Page Number")
Word = InputBox("Enter Word to Delete", "Keep The first")

Selection.GoTo What:=wdGoToPage, Count:=Page

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Color = wdColorRed

With Selection.Find
.Text = Word
.Replacement.Text = Word
.Forward = True
'.Wrap = Forward
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceOne

Selection.Find.ClearFormatting
Selection.Find.Font.Color = wdColorAutomatic
Selection.Find.Replacement.ClearFormatting

With CurrentPage
With Selection.Find
.Text = Word
.Replacement.Text = ""
.Forward = True
.Wrap = Forward
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End With
Selection.Find.Execute Replace:=wdReplaceAll

Selection.Find.ClearFormatting
Selection.Find.Font.Color = wdColorRed
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Color = wdColorAutomatic

With Selection.Find
.Text = Word
.Replacement.Text = Word
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
MsgBox Word + " deleted on the selected page except for the first occurrence"
End Sub