マナ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<I>$2</I>$3") re1.Pattern = "<B>(<Font[\s\S]*?(?!Style)>)([\s\S]*?)(</Font>)*</B>" s = re1.Replace(s, "$1<B>$2</B>$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<B>$2</B>$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<I>$2</I>$3") End If Next End If ' re1.Pattern = "((<ss:|<)Data[\s\S]*?>)([\s\S]*?)(<(/ss:|/)Data>)" s = re1.Replace(s, "$1<P>$3</P>$4") re1.Pattern = "& # 10;" '<--remove space s = re1.Replace(s, "<P></P>") 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