VBA Excel更改斜体并添加</和/>

我想知道是否有人遇到类似的东西。

Excel列中有一个列表，在文本中插入斜体。 就像是：

第一行： Calidris pugnax的分布已经减less

第二排： Hydrotaea glabricula不再是受到威胁的物种

第三排：将实施鳞翅目 （ Peltigera lepidophora）计划

第四行： 松萝西里西亚现在已经灭绝

…

我需要在Excel中使用一些VBA代码，如下所示：在斜体前后插入这些标签。

第一行：Calidris pugnax 2的分布已经减less

第二行：水gla glabricula 2不再是受威胁的物种

第三行：将执行用于<1>的鳞翅目（Peltigera lepidophora）<2>的scheme

第四行：<1>西番莲现在已经灭绝

…

你有什么想法如何做到这一点？ 这是用于只识别标签的网站（<1>和<2>仅用于清楚我需要的内容），而不是斜体。

问候，

DASCO

Answer 1

你可以使用这样的例程：

Sub TagItalics() Dim lngStart As Long Dim lngFinish As Long Dim n As Long Dim rngCell As Range Dim rngConstants As Range On Error Resume Next Set rngConstants = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants) On Error GoTo 0 If Not rngConstants Is Nothing Then Application.ScreenUpdating = False For Each rngCell In rngConstants.Cells lngStart = 0 For n = 1 To Len(rngCell.Value) If rngCell.Characters(n, 1).Font.Italic Then If lngStart = 0 Then lngStart = n ElseIf lngStart <> 0 Then lngFinish = n Exit For End If Next n If lngStart <> 0 Then rngCell.Characters(lngStart, 0).Insert "<1>" rngCell.Characters(lngFinish + 3, 0).Insert "<2>" End If Next rngCell Application.ScreenUpdating = True End If End Sub 

Answer 2

我不认为你可以通过Excel中的VBA获取有关部分单元格文本的字体信息。 我可以想一个解决方法。

1. 将该列复制到MS Word
2. logging一个macros来做
3. 使用Word的高级查找search格式设置为斜体的文本
4. find下一个匹配的文本，Word将select斜体文本，replace为<1>选定的文本<2>，确保将选定的文本的字体设置为非斜体
5. 重复，直到找不到。

– 在Rory的评论之后编辑如果使用Excel 2010，可以这样做

 Sub MarkItalics() Dim cell As Range, char As Characters, insideItalic As Boolean, content As String, newContent As String Dim startIndex As Integer, endIndex As Integer, foundItalics As Boolean For Each cell In Range("A1:A50") insideItalic = False foundItalics = False content = cell.Value If content <> "" Then For i = 1 To Len(content) Set char = cell.Characters(i, 1) If char.Font.Italic And insideItalic = False Then newContent = Mid(content, 1, i - 1) & ("<1>") startIndex = i - 1 insideItalic = True foundItalics = True ElseIf Not char.Font.Italic And insideItalic Then newContent = newContent & Mid(content, startIndex + 1, i - startIndex) & "<2>" insideItalic = False endIndex = i - 1 End If Next newContent = newContent & Mid(content, endIndex) If foundItalics Then cell.Value = newContent End If Next End Sub