customSearchFunction01.vba

'Please refer to https://docs.microsoft.com/fr-fr/office/vba/api/word.wdcolorindex to get other colours values
Const highLightColor1 = 4
Const highLightColor2 = 11
Dim savedWordAposition As Integer
Dim savedWordBposition As Integer

Private Sub Userform_Initialize()
    Search.TextBox1.Text = ""
    Search.TextBox2.Text = ""
    Search.TextBox4.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 TextBox4_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 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:
    flg = False
    ReDim wordApositions(1)
    ReDim wordBpositions(1)
    wordA = Search.TextBox1.Value
    wordB = Search.TextBox2.Value
    wordAStarter = StrConv(wordA, 3)
    wordBStarter = StrConv(wordB, 3)
    numOfLines = ActiveDocument.BuiltInDocumentProperties("NUMBER OF LINES")
    If Len(Trim(Search.TextBox4.Value)) Then
        lineInterval = CInt(Search.TextBox4.Value)
    Else
        lineInterval = numOfLines
    End If
    lineCounter = 0

    If wordA = "" And wordB = "" Then
        MsgBox "Please fill at least one search word", "", vbExclamation
    ElseIf Not wordA = "" And wordB = "" Then
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = Search.TextBox1.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
            currLine = Left(currLine, (Len(currLine) - 1))
            If Not IsEmpty(wordA) And Not wordA = "" Then
                If InStr(currLine, wordA) Then
                    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
            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 (wordApositions(j) >= wordApositions(j - 1) - 3) And (wordApositions(j) <= wordApositions(j - 1) + 3) Then
                            savedWordAposition = j + 1
                            GoTo function_Restart
                        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()
    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