Option Explicit

Sub test2()
    Dim re1 As Object, re2 As Object
    Dim s As String
    Dim r As Range
    Dim m As Object
    
    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 = "<I>(<Font[\s\S]*?>)([\s\S]*?)(</Font>)*</I>"
    s = re1.Replace(s, "$1&lt;I&gt;$2&lt;/I&gt;$3")
    
  re1.Pattern = "<B>(<Font[\s\S]*?(?!Style)>)([\s\S]*?)(</Font>)*</B>"
    s = re1.Replace(s, "$1&lt;B&gt;$2&lt;/B&gt;$3")
  
    re2.Pattern = "<Style ss:(ID=""s\d*"")>([\s\S]*?)</Style>"
    If re2.test(s) Then
        For Each m In re2.Execute(s)
            If InStr(m.submatches(1), "ss:Bold=""1""") > 0 Then
                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")
            End If
            If InStr(m.submatches(1), "ss:Italic=""1""") > 0 Then
                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")
            End If
        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 = "& # 10;"　'<--remove space
    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
マナ