Sub Italique()
Dim cel As Range, txt$, i%, txt1$, txt2$
For Each cel In Range("A2", [A65536].End(xlUp))
txt = ""
For i = 1 To Len(cel)
txt1 = "": txt2 = ""
If cel.Characters(i, 1).Font.Italic Then
If i = 1 Or Not cel.Characters(i - 1, 1).Font.Italic Then txt1 = "<i>"
Else
If cel.Characters(i - 1, 1).Font.Italic Then txt2 = "</i>"
End If
txt = txt & txt1 & txt2 & Mid(cel, i, 1)
Next
If txt <> "" And cel.Characters(i - 1, 1).Font.Italic Then txt = txt & "</i>"
cel.Offset(, 1) = txt
Next
End Sub