'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