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.Value = Replace(ActiveCell.Text, OpenTag, "")
    ActiveCell.Value = Replace(ActiveCell.Text, CloseTag, "")
    
    If Mid(OpenTag,  2 ,  1 ) = "b" Then ActiveCell.Characters(x1, Len(s)).Font.Bold = True
    If Mid(OpenTag,  2 ,  1 ) = "i" Then ActiveCell.Characters(x1, Len(s)).Font.Italic = 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>"
            Set r = Cells.FindNext(r)
            If r Is Nothing Then Exit Do
        Loop While r.Address <> firstadress
    End If
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 "<sup>", "</sup>"
            Set r = Cells.FindNext(r)
            If r Is Nothing Then Exit Do
        Loop While r.Address <> firstadress
    End If
End Sub