IncrementalReplacementMacro

Sub IncrementalReplacementMacro()
    Dim UndoObject As UndoRecord
    Set UndoObject = Application.UndoRecord
    UndoObject.StartCustomRecord ("Incremental replacement macro")
    Application.ScreenUpdating = False
    With ActiveDocument.Range
      With .Find
        .ClearFormatting
        .Text = "10500" 'All enteries of this text will be replaced
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Execute
      End With
      Counter = 777 'The first value of the id to be used
      Do While .Find.Found
        .Text = "¹" + LTrim(Str(Counter)) 'Expression that calculates text for replacement
        Counter = Counter + 1 'Update the value of counter for the next replacement
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    Application.ScreenUpdating = True
    UndoObject.EndCustomRecord
End Sub