I’m trying to write a VBA macro in Microsoft Word that removes all the watermarks in the document. The first step is easy, I just need to remove all the front wrapped text. Sometimes, the watermarks are in text boxes that are in the top and bottom of the page and mixed in with other text, so I need to remove the repeating text while preserving the existing text. I wrote this macro which does the job, but takes multiple minutes to run on documents that are potentially over one hundred pages long.

Sub CompleteRemover()
Dim doc As Document
Dim shp As Shape
Dim shpRange As Range
Dim textDict As Object
Dim pageDict As Object
Dim key As Variant
Dim text As String
Dim pageCollection As Object
Dim shapesToProcess As Collection
Dim shpInfo As Variant
Dim i As Long
Dim pageCount As Long

' Create dictionary objects to store text counts and page occurrences
Set textDict = CreateObject("Scripting.Dictionary")
Set pageDict = CreateObject("Scripting.Dictionary")
Set shapesToProcess = New Collection

' Reference the active document
Set doc = ActiveDocument

' Disable screen updating to improve performance
Application.ScreenUpdating = False

' Get the total number of pages in the document
pageCount = doc.ComputeStatistics(wdStatisticPages)

' Loop through shapes in reverse order to avoid indexing issues when deleting shapes
For i = doc.Shapes.Count To 1 Step -1
    Set shp = doc.Shapes(i)
    On Error Resume Next

    ' Check for watermarks
    If shp.WrapFormat.Type = wdWrapFront Then
        shp.Delete
    End If

    ' Check for text boxes in headers/footers
    If shp.Type = msoTextBox And shp.TextFrame.HasText Then
        Set shpRange = shp.Anchor.Paragraphs(1).Range
        Dim pageIndex As Long
        pageIndex = shpRange.Information(wdActiveEndPageNumber)
        text = Left(shp.TextFrame.textRange.text, 255) ' Limit to 255 characters

        ' Store shape information in a collection
        shapesToProcess.Add Array(shp, text, pageIndex)

        If textDict.Exists(text) Then
            textDict(text) = textDict(text) + 1
            Set pageCollection = pageDict(text)
            If Not pageCollection.Exists(pageIndex) Then
                pageCollection.Add pageIndex, True
            End If
        Else
            textDict.Add text, 1
            Set pageCollection = CreateObject("Scripting.Dictionary")
            pageCollection.Add pageIndex, True
            pageDict.Add text, pageCollection
        End If
    End If
    On Error GoTo 0
Next i

' Second pass: Remove the watermark text from the textboxes with repeating text on every page
For Each key In textDict.Keys
    If pageDict(key).Count = pageCount Then
        For Each shpInfo In shapesToProcess
            Set shp = shpInfo(0)
            text = shpInfo(1)
            If InStr(text, key) > 0 Then
                With shp.TextFrame.textRange.Find
                    .text = key
                    .Replacement.text = ""
                    .Forward = True
                    .Wrap = wdFindStop
                    .Format = True
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=wdReplaceAll
                End With
            End If
        Next shpInfo
    End If
Next key

' Re-enable screen updating
Application.ScreenUpdating = True

' Display completion message
MsgBox "Watermarks Removed."
End Sub

I tried limiting what the program checks, such as only checking the last two or three text boxes to see if they’re front wrapped, or only checking certain margins in the page for the watermarks, but it ended up breaking the code.