VBA Find c циклом

Sub Find2()
Dim oFile, wsSh As Worksheet, Openbook, Book
Set wsh = CreateObject("WScript.Shell")
docs = wsh.SpecialFolders("Desktop") 'получение адреса рабочего стола
CurrentPath = ThisWorkbook.Path ' получение адреса текущей папки
Form = "Юр _форм _автозамена.doc"
Set obook = Workbooks.Open(docs & "\" & "crm_ui_frame(1)") ' имя книги по умолчанию
         Dim oWord As Word.Application
            Dim oDoc As Word.Document
            Set oWord = CreateObject("Word.Application")
            Set oDoc = oWord.Documents.Add(CurrentPath & "\" & Form) 'запускаем форму
            oWord.Visible = True
            oWord.Tasks("Microsoft Word").Activate
            'oWord.Application.ScreenUpdating = False
           ' thisdocument.Activate
Set myRange = oDoc.Content
     myRange.Find.ClearFormatting
    With myRange.Find
        .Text = "[[]?*[]]"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchWildcards = True
        .Execute
            Do While .Found = True
                'MsgBox myRange
                .Execute
                Codes = Mid(myRange, 2, Len(myRange) - 2)
     Set sRow = Cells.Find(What:=Codes, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
If Not sRow Is Nothing Then
        sRow = sRow.Row
        Values = obook.Sheets(1).Range("B" & sRow).Value
        oDoc.Content.Find.ClearFormatting
   With oDoc.Content.Find
        .Text = myRange
        .Replacement.Text = Values
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceAll, Forward:=True
    End With
Else:
myRange.HighlightColorIndex = wdRed
Codes = Mid(myRange, 2, Len(myRange) - 2)
With oDoc.Content.Find
        .Text = myRange
        .Replacement.Text = Chr(34) & Codes & Chr(34)
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceAll, Forward:=True
    End With
 End If
For k = 1 To oDoc.Sections.Count
    'Поиск в верхних колонтитулах
    For Each oHeadFtr In oDoc.Sections(k).Headers
     Call SearchInRange(oHeadFtr.Range)
    Next
    'Поиск в нижних колонтитулах
    For Each oHeadFtr In oDoc.Sections(k).Footers
    ' Call SearchInRange(oHeadFtr.Range, m:=Codes, k:=Values)
    Next
  Next
  Loop
End With
End Sub
Function SearchInRange(oRng) As Boolean
Set obook = Workbooks("crm_ui_frame(1)") ' имя книги по умолчанию
  With oRng.Find
        .Text = "[[]?*[]]"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchWildcards = True
        .Execute
 Do While .Found = True
    .Execute
Codes = Mid(oRng, 2, Len(oRng) - 2)
Set sRow = Cells.Find(What:=Codes, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
If Not sRow Is Nothing Then
        sRow = sRow.Row
        Values = obook.Sheets(1).Range("B" & sRow).Value
        oRng.Find.ClearFormatting
   With oRng.Find
        .Text = oRng
        .Replacement.Text = Values
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceAll
    End With
Else:
oRng.HighlightColorIndex = wdRed
Codes = Mid(oRng, 2, Len(oRng) - 2)
With oRng.Find
        .Text = oRng
        .Replacement.Text = Chr(34) & Codes & Chr(34)
        .Forward = True
        .Format = False
        .Execute Replace:=wdReplaceOne, Forward:=True
    End With
 End If
 Loop
 End With
End Function