evolvedSearchWordV1.vba

'Declare the Userform modeless : userForm1.Show 0
'If the search is frozen press Ctrl+Break to stop the macro
'Tables larger than one page will prevent the search from going further
'Please refer to https://docs.microsoft.com/fr-fr/office/vba/api/word.wdcolorindex to get other colours values
Const highLightColor1 = 4
Const highLightColor2 = 7
Dim savedWordAposition As Integer
Dim savedWordBposition As Integer

Private Sub Userform_Initialize()
    If ActiveDocument.ProtectionType = wdProtection Then
        MsgBox "Document is protected", "", vbExclamation
        Unload Me
    End If
    userForm1.TextBox1.Text = ""
    userForm1.TextBox2.Text = ""
    userForm1.TextBox3.Text = ""
    savedWordAposition = 0
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call CommandButton2_Click
    Unload Me
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyAscii As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyAscii = 27 Then
        Call CommandButton2_Click
        Unload Me
    ElseIf KeyAscii = 13 Then
        Call CommandButton1_Click
    End If
End Sub

Private Sub TextBox2_KeyDown(ByVal KeyAscii As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyAscii = 27 Then
        Call CommandButton2_Click
        Unload Me
    ElseIf KeyAscii = 13 Then
        Call CommandButton1_Click
    End If
End Sub

Private Sub TextBox3_KeyDown(ByVal KeyAscii As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyAscii = 27 Then
        Call CommandButton2_Click
        Unload Me
    ElseIf KeyAscii = 13 Then
        Call CommandButton1_Click
    End If
End Sub

Private Sub UserForm_KeyDown(ByVal KeyAscii As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyAscii = 27 Then
        Call CommandButton2_Click
        Unload Me
    ElseIf KeyAscii = 13 Then
        Call CommandButton1_Click
    End If
End Sub

Private Sub CommandButton1_KeyDown(ByVal KeyAscii As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyAscii = 27 Then
        Call CommandButton2_Click
        Unload Me
    ElseIf KeyAscii = 13 Then
        Call CommandButton1_Click
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim wordA  As String
    Dim wordB  As String
    Dim wordAStarter  As String
    Dim wordBStarter  As String
    Dim wordAStarterPos  As Integer
    Dim wordBStarterPos  As Integer
    Dim lineInterval As Integer
    Dim currLine As String
    Dim numOfLines As Integer
    Dim wordApositions() As Variant
    Dim wordBpositions() As Variant
    Dim wordAposSize As Integer
    Dim wordBposSize As Integer
    Dim flg As Boolean

function_Restart:
    stopProcessing = False
    flg = False
    ReDim wordApositions(1)
    ReDim wordBpositions(1)
    wordA = userForm1.TextBox1.Value
    wordB = userForm1.TextBox2.Value
    wordAStarterPos = Asc(Left(wordA, 1))
    Select Case wordAStarterPos
        Case 65 To 90
            wordAStarter = StrConv(wordA, 2)
        Case Else
            wordAStarter = StrConv(wordA, 3)
    End Select
    wordBStarterPos = Asc(Left(wordB, 1))
    Select Case wordBStarterPos
        Case 65 To 90
            wordBStarter = StrConv(wordB, 2)
        Case Else
            wordBStarter = StrConv(wordB, 3)
    End Select
    numOfLines = ActiveDocument.BuiltInDocumentProperties("NUMBER OF LINES")
    If Len(Trim(userForm1.TextBox3.Value)) Then
        lineInterval = CInt(userForm1.TextBox3.Value)
    Else
        lineInterval = numOfLines
    End If
    lineCounter = 0

    If wordA = "" And wordB = "" Then
        MsgBox "Please fill at least one UserForm1 word", "", vbExclamation
    ElseIf Not wordA = "" And wordB = "" Then
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = userForm1.TextBox1.Value
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
        End With
    ElseIf wordA = "" And Not wordB = "" Then
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = userForm1.TextBox2.Value
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
        End With
    ElseIf Not wordA = "" And Not wordB = "" Then
        Selection.HomeKey Unit:=wdStory
        For i = 1 To numOfLines
            Selection.HomeKey Unit:=wdLine
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend
            currLine = Selection.Range.Text
            If Not currLine = "" And Not Selection.Information(wdWithInTable) Then
                currLine = Left(currLine, (Len(currLine) - 1))
                If Not IsEmpty(wordA) And Not wordA = "" Then
                    If InStr(currLine, wordA) Then
                        'Debug.Print "Occurence '" & wordA & "' on line : " & i
                        wordAposSize = UBound(wordApositions) - 1
                        wordApositions(wordAposSize) = i
                        wordAposSize = wordAposSize + 2
                        ReDim Preserve wordApositions(wordAposSize)
                    End If
                End If
                If Not IsEmpty(wordB) And Not wordB = "" Then
                    If InStr(currLine, wordB) Then
                        wordBposSize = UBound(wordBpositions) - 1
                        wordBpositions(wordBposSize) = i
                        wordBposSize = wordBposSize + 2
                        ReDim Preserve wordBpositions(wordBposSize)
                    End If
                End If
                If Not IsEmpty(wordAStarter) And Not wordAStarter = "" Then
                    If InStr(currLine, wordAStarter) Then
                        wordAposSize = UBound(wordApositions) - 1
                        wordApositions(wordAposSize) = i
                        wordAposSize = wordAposSize + 2
                        ReDim Preserve wordApositions(wordAposSize)
                    End If
                End If
                If Not IsEmpty(wordBStarter) And Not wordBStarter = "" Then
                    If InStr(currLine, wordBStarter) Then
                        wordBposSize = UBound(wordBpositions) - 1
                        wordBpositions(wordBposSize) = i
                        wordBposSize = wordBposSize + 2
                        ReDim Preserve wordBpositions(wordBposSize)
                    End If
                End If
            End If
            Selection.MoveDown Unit:=wdLine, Count:=1
        Next i

        If Not IsEmpty(wordA) And Not wordA = "" And Not IsEmpty(wordB) And Not wordB = "" Then
            If savedWordAposition = UBound(wordApositions) Or wordApositions(savedWordAposition) = "" Then
                savedWordAposition = 0
            End If
            For j = savedWordAposition To UBound(wordApositions)
                For k = LBound(wordBpositions) To UBound(wordBpositions)
                    If Not wordBpositions(k) = "" And Not wordApositions(j) = "" And wordBpositions(k) >= wordApositions(j) - (lineInterval / 2) And wordBpositions(k) <= wordApositions(j) + (lineInterval / 2) Then
                        If ((j - 1) - 3) >= LBound(wordApositions) And ((j - 1) + 3) <= UBound(wordApositions) Then
                            If (wordApositions(j) >= wordApositions(j - 1) - 3) And (wordApositions(j) <= wordApositions(j - 1) + 3) Then
                                savedWordAposition = j + 1
                                GoTo function_Restart
                            End If
                        End If
                        Call HighLightText(wordA, wordB)
                        Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=wordApositions(j)
                        savedWordAposition = j + 1
                        flg = True
                        Exit For
                    End If
                Next k
                If flg = True Then
                    Exit For
                End If
            Next j
        End If
    End If
End Sub

Private Sub CommandButton2_Click()
    stopProcessing = True
    savedWordAposition = 0
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    For Each StoryRange In ActiveDocument.StoryRanges
        StoryRange.HighlightColorIndex = wdNoHighlight
    Next StoryRange
    Application.Selection.EndOf
End Sub

Sub HighLightText(wordA As String, wordB As String)
Dim Word As Range
    Dim WordCollection(1) As String
    Dim Colors(1) As WdColorIndex
    Dim CurrentColor As WdColorIndex
    Dim i As Long

    WordCollection(0) = wordA
    WordCollection(1) = wordB
    Colors(0) = highLightColor1
    Colors(1) = highLightColor2
    CurrentColor = Options.DefaultHighlightColorIndex
    Application.ScreenUpdating = False
    With ActiveDocument.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Replacement.Highlight = True
        For i = 0 To 1
            Options.DefaultHighlightColorIndex = Colors(i)
            .Execute FindText:=WordCollection(i), Replace:=wdReplaceAll
        Next i
    End With
    Application.ScreenUpdating = True
    Options.DefaultHighlightColorIndex = CurrentColor
End Sub