单词的音标通过公式提取后，原有的斜体 角标 下划线 怎样保留

'觉得解决起来挺费劲的，写了一个测试代码。
'先获取单元格中各元素指定的属性到一个数组中去（这里假设是4个属性）
'截取字符串，再调取先前的属性设置新的字符串属性
Option Explicit
Type rngfontattr
　　itc As Boolean '斜体
　　up As Boolean '上标
　　down As Boolean '下标
　　udlne As Long '下划线
End Type
Sub test()
　　Dim fontattr As rngfontattr, i
　　With [d8] '获取属性
　　　　For i = 1 To Len([d8])
　　　　　　fontattr.itc = .Characters(i, 1).font.Italic
　　　　　　fontattr.up = .Characters(i, 1).font.Superscript
　　　　　　fontattr.down = .Characters(i, 1).font.Subscript
　　　　　　fontattr.udlne = .Characters(i, 1).font.Underline
　　　　　　Debug.Print fontattr.itc,
　　　　　　Debug.Print fontattr.up,
　　　　　　Debug.Print fontattr.down,
　　　　　　Debug.Print fontattr.udlne
　　　　Next
　　End With
End Sub

Option Explicit
Sub test()
　　Dim i, j
　　For i = 2 To [b65536].End(xlUp).Row
　　　　Cells(i, 4) = Split(Cells(i, 2), "t")(0) '假设都有"t"且小写
　　　　For j = 1 To Len(Cells(i, 4))
　　　　　　Cells(i, 4).Characters(j, 1).font.Italic = Cells(i, 2).Characters(j, 1).font.Italic
　　　　　　Cells(i, 4).Characters(j, 1).font.Superscript = Cells(i, 2).Characters(j, 1).font.Superscript
　　　　　　Cells(i, 4).Characters(j, 1).font.Subscript = Cells(i, 2).Characters(j, 1).font.Subscript
　　　　　　Cells(i, 4).Characters(j, 1).font.Underline = Cells(i, 2).Characters(j, 1).font.Underline
　　Next j, i
End Sub

'直接运行test即可，可以在for j循环中添加或删除指定的属性

Option Explicit
Sub test()
　　Dim i, j
　　For i = 2 To [b65536].End(xlUp).Row
　　　　Cells(i, 4) = Split(Cells(i, 2), "t")(0) '假设都有"t"且小写
　　　　For j = 1 To Len(Cells(i, 4))
　　　　　　Cells(i, 4).Characters(j, 1).font.Italic = Cells(i, 2).Characters(j, 1).font.Italic
　　　　　　Cells(i, 4).Characters(j, 1).font.Superscript = Cells(i, 2).Characters(j, 1).font.Superscript
　　　　　　Cells(i, 4).Characters(j, 1).font.Subscript = Cells(i, 2).Characters(j, 1).font.Subscript
　　　　　　Cells(i, 4).Characters(j, 1).font.Underline = Cells(i, 2).Characters(j, 1).font.Underline
　　　　　　Cells(i, 4).Characters(j, 1).font.Size = Cells(i, 2).Characters(j, 1).font.Size
　　　　　　Cells(i, 4).Characters(j, 1).font.Bold = Cells(i, 2).Characters(j, 1).font.Bold
　　Next j, i
End Sub

Sub heh()
Range([C2], [C65536].End(xlUp)).Copy [D2]
For Each i In Range([D2], [D65536].End(xlUp))
If InStr(i, "t") Then i.Characters(Start:=InStr(i, "t"), Length:=99).Delete
Next
End Sub
写了一个，删除后边字段的代码。

Sub heh()
Range([C2], [C65536].End(xlUp)).Copy [D2]
For Each i In Range([D2], [D65536].End(xlUp))
If InStr(i, "t") Then
i.Characters(1, 0).Text = "''"
i.Characters(InStr(i, "t"), 99).Delete
End If
Next
End Sub