Выделение текста от и до заданного тега в Excel`e

Private Sub ChangeFormatHTMLTag()

Application.ScreenUpdating = False

Dim iCell As Range, iStart%, iEnd%
Dim iOpenTag$, iCloseTag$, iHTMLTag

With ThisWorkbook.Worksheets(1)
     'укажите свою книгу/лист, лист не должен быть защищён (97, 2000)
     'т.к. возможность изменения параметров форматирования
     'нижеуказанным способом появилась только в MS Excel XP
     '(при установке опции разрешить форматирование ячеек)
     For Each iHTMLTag In Array("<B>*</B>", "<I>*</I>")
         Set iCell = .UsedRange.Find _
         (What:=iHTMLTag, LookIn:=xlValues, LookAt:=xlPart)
         If Not iCell Is Nothing Then
            iOpenTag = Left(iHTMLTag, 3)
            iCloseTag = Right(iHTMLTag, 4)
            Do Until iCell Is Nothing
               If Not iCell.HasFormula Then
                  'Если Вы уверены, что у Вас нет формул, которые
                  'могут возвращать текст содержащий нужные тэги, то
                  'проверку можно убрать
                  iStart = InStr(1, iCell, iOpenTag, vbTextCompare)
                  iEnd = InStr(1, iCell, iCloseTag, vbTextCompare)
                  Do
                     With iCell.Characters _
                          (Start:=iStart, Length:=iEnd - iStart)
                          If iHTMLTag = "<B>*</B>" Then
                             .Font.Bold = True
                          Else
                             .Font.Italic = True
                          End If
                     End With
                     iCell.Characters(Start:=iStart, Length:=3).Text = ""
                     iCell.Characters(Start:=iEnd - 3, Length:=4).Text = ""
                     
                     iStart = InStr(1, iCell, iOpenTag, vbTextCompare)
                     iEnd = InStr(1, iCell, iCloseTag, vbTextCompare)
                  Loop While (iStart <> 0 And iEnd <> 0) 'maybe ...
               End If
               Set iCell = .UsedRange.FindNext(After:=iCell)
            Loop
         End If
     Next
End With

Application.ScreenUpdating = True

End Sub

Sub ReplaceTags(OpenTag As String, CloseTag As String)
    Dim x1 As Integer
    Dim x2 As Integer
    Dim s As String

    x1 = InStr(ActiveCell.Text, OpenTag)
    x2 = InStr(ActiveCell.Text, CloseTag)
    If x1 = 0 Or x2 = 0 Then Exit Sub
    s = Mid(ActiveCell.Text, x1 + Len(OpenTag), x2 - x1 - Len(OpenTag))

    ActiveCell.Characters(x1, Len(OpenTag)).Delete
    ActiveCell.Characters(x2 - Len(OpenTag), Len(CloseTag)).Delete
   
    If Mid(OpenTag, 2, Len(OpenTag) - 2) = "b" Then ActiveCell.Characters(x1, Len(s)).Font.Bold = True
    If Mid(OpenTag, 2, Len(OpenTag) - 2) = "i" Then ActiveCell.Characters(x1, Len(s)).Font.Italic = True
    If Mid(OpenTag, 2, Len(OpenTag) - 2) = "sup" Then ActiveCell.Characters(x1, Len(s)).Font.Superscript = True
   
End Sub

Sub StartReplaceTags()
    Dim r As Range
    Dim firstadress As String
   
    Set r = Cells.Find(What:="<*>*</*>", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not r Is Nothing Then
        firstadress = r.Address
        Do
            r.Activate
            ReplaceTags "<b>", "</b>"
            ReplaceTags "<i>", "</i>"
            ReplaceTags "^{", "}"
            Set r = Cells.FindNext(r)
            If r Is Nothing Then Exit Do
        Loop While r.Address <> firstadress
    End If
End Sub