Option Explicit

Sub test()
    Dim re1 As Object
    Dim re2 As Object
    Dim s As String
    Dim r As Range
    Dim m, k
    
    Set r = Selection
    s = r.Value(xlRangeValueXMLSpreadsheet)
    
    Set re1 = CreateObject("VBScript.RegExp")
    re1.Global = True
    Set re2 = CreateObject("VBScript.RegExp")
    re2.Global = True
'
    re1.Pattern = "<B>(<Font[\s\S]*?>)([\s\S]*?)(</Font>)*</B>"
    s = re1.Replace(s, "$1&lt;B&gt;$2&lt;/B&gt;$3")
    
    re1.Pattern = "<I>(<Font[\s\S]*?>)([\s\S]*?)(</Font>)*</I>"
    s = re1.Replace(s, "$1&lt;I&gt;$2&lt;/I&gt;$3")
        
    re2.Pattern = "<Style ss:(ID=""s\d*"")>[\n\s]*?<Font[^>]*?ss:Bold=""1"""
    If re2.test(s) Then
        For Each m In re2.Execute(s)
            re1.Pattern = "(<Cell ss:Style" & m.submatches(0) & "><Data ss:Type=""String"">)([\s\S]*?)(</Data>)"
            s = re1.Replace(s, "$1&lt;B&gt;$2&lt;/B&gt;$3")
        Next
    End If

    re2.Pattern = "<Style ss:(ID=""s\d*"")>[\n\s]*?<Font[^>]*?ss:Italic=""1"""
    If re2.test(s) Then
        For Each m In re2.Execute(s)
            re1.Pattern = "(<Cell ss:Style" & m.submatches(0) & "><Data ss:Type=""String"">)([\s\S]*?)(</Data>)"
            s = re1.Replace(s, "$1&lt;I&gt;$2&lt;/I&gt;$3")
        Next
    End If

    re1.Pattern = "((<ss:|<)Data[\s\S]*?>)([\s\S]*?)(<(/ss:|/)Data>)"
    s = re1.Replace(s, "$1&lt;P&gt;$3&lt;/P&gt;$4")
    
    re1.Pattern = "
"
    s = re1.Replace(s, "&lt;P&gt;&lt;/P&gt;")
      
    r.Offset(, 2).Value(xlRangeValueXMLSpreadsheet) = s
    r.Offset(, 2).ClearFormats
    r.Offset(, 2).Font.Bold = False
    r.Offset(, 2).Font.Italic = False
'
    Set re1 = Nothing
    Set re2 = Nothing
    
End Sub

マナ