Visual Basic para Aplicaciones - Buscar palabras consecutivas en word

Sub Verbos_Compuestos()

    Application.ScreenUpdating = False

    'Ejemplo: Ha comido, ha visto, ha dicho, ha impreso

    '-> Lista primera palabra: Ha, ha (para tercera persona de singular)

    '-> Lista de terminaciones de participios: to, do, so (idem)

    Dim Texto1, Texto2 As String

    Dim TargetList

    Dim Encontrado As Integer

    Dim Palabras As Long

    Dim i As Long, j As Integer

    Dim Seguir As Boolean

    Dim Tiempo As Date, hInicio As Date

    hInicio = Now() 'Comenzamos!!

    Encontrado = 0

    TargetList = Array("do", "to", "ho", "so")

    Palabras = ActiveDocument.Words.Count

    Selection.HomeKey wdStory

    Selection.Find.ClearFormatting

    Do

        With Selection.Find

            .Text = "ha"

            .Replacement.Text = ""

            .Forward = True             'Hacia adelante

            .Wrap = wdFindStop          'Parar al llegar al final del documento

            .Format = False             'Sin formato

            .MatchCase = False          'Sin coincidencia de may/min

            .MatchWholeWord = True      'Palabras completas

            .MatchWildcards = False     'Sin comodines

            .MatchSoundsLike = False    'Sin aproximaciones sonoras

            .MatchAllWordForms = False  'No encontrar todas las formas de la palabra

            Seguir = .Execute

        End With

        If Seguir Then 'Se ha encontrado

            Selection.Expand wdWord 'Seleccionamos toda la palabra

            Selection.MoveRight wdWord, 1, True 'Seleccionamos la siguiente palabra

            Texto1 = Trim(Selection)  'Las dos palabras

            Texto2 = Right(Texto1, 2)

            For j = 0 To UBound(TargetList)

                If Texto2 = TargetList(j) Then

                    Selection.Words(1).HighlightColorIndex = wdPink

                    Selection.Words(2).HighlightColorIndex = wdRed

                    Encontrado = Encontrado + 1

                    Exit For

                End If

            Next

            Selection.Collapse wdCollapseEnd 'Deseleccionamos el texto situando el cursor al final

        End If

    Loop While Seguir

    Tiempo = Now() - hInicio

    System.Cursor = wdCursorNormal

    MsgBox ("He encontrado " & Encontrado & " casos en un documento de " & _

            Palabras & " palabras en " & Format(Tiempo, "h ""horas"" m ""minutos"" s ""segundos""") & ".")

End Sub