在斜体字符串周围插入标签

Question

我是 VBA 的新手，正在尝试编写一个脚本，在 Excel 中的斜体文本周围插入 XML 标记。我发现了这个问题：VBA Excel Changing Italics and adding

第一个答案的方法很巧妙，我正在修改该代码。它适用于单元格中的第一个斜体字符串，但不适用于后续字符串。

这是我正在尝试的代码。它遍历每个字符，直到找到第一个斜体并插入一个标记并将 lngCount 变量变为 True。当找到常规文本时，如果 lngCount 变量为 True，它会插入结束标记并将变量重置为 False。

它在某些单元格中工作得很好，但在其他地方它不插入结束标记，而在其他地方它不插入任何标记。由于我无法弄清楚什么时候效果好，什么时候不好，有什么一致的区别，有人能帮忙吗？我对 vba 有什么误解吗？

Sub EmphTags()
    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
            lngCount = False
            lngStart = 0
            lngFinish = 0
            For n = 1 To Len(rngCell.Text)
                If rngCell.Characters(n, 1).Font.Color = 0 Then
                    If rngCell.Characters(n, 1).Font.Italic Then
                        If lngCount = False Then
                            lngStart = n
                            rngCell.Characters(lngStart, 0).Insert "<emph render='italic'>"
                            rngCell.Characters(lngStart, 22).Font.Italic = True
                        End If
                        lngCount = True
                    ElseIf lngCount = True Then
                        lngFinish = n
                        rngCell.Characters(lngFinish, 0).Insert "</emph>"
                        rngCell.Characters(lngFinish, 7).Font.Italic = False
                        lngCount = 0
                    End If
                End If
            Next n
        Next rngCell
        'Application.ScreenUpdating = True
    End If
End Sub

Answer 1

在你的循环中：

For n = 1 To Len(rngCell.Text)

Len(rngCell.Text) 只计算一次（当你第一次进入循环时）。不要使用 For...Next，而是使用 Do While 循环或类似的循环，这样您就可以 "keep up" 处理因添加标签而导致的长度变化。

编辑：在光测试中这对我有用

Sub EmphTags()

    Const TAG_EMPH_START As String = "<emph render='italic'>"
    Const TAG_EMPH_END As String = "</emph>"

    Dim lngStart As Long
    Dim n As Long
    Dim rngCell As Range
    Dim rngConstants As Range
    Dim isItalic As Boolean

    On Error Resume Next
    Set rngConstants = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0

    If Not rngConstants Is Nothing Then

        For Each rngCell In rngConstants.Cells

            lngStart = 0
            n = 1

            Do While n <= Len(rngCell.Text)

                If rngCell.Characters(n, 1).Font.Color = 0 Then

                    isItalic = rngCell.Characters(n, 1).Font.Italic

                    If isItalic And lngStart = 0 Then lngStart = n

                    If Not isItalic And lngStart > 0 Then
                        TagText rngCell, lngStart, n, TAG_EMPH_START, TAG_EMPH_END
                    End If

                End If
                n = n + 1
            Loop

            'deal with cases where terminal character(s) are italic
            If lngStart > 0 Then
                TagText rngCell, lngStart, n, TAG_EMPH_START, TAG_EMPH_END
            End If

        Next rngCell

    End If
End Sub

Sub TagText(rngCell As Range, ByRef lngStart As Long, ByRef lngEnd As Long, _
              tagStart As String, tagEnd As String)

    rngCell.Characters(lngStart, 0).Insert tagStart
    rngCell.Characters(lngEnd + Len(tagStart), 0).Insert tagEnd
    lngEnd = lngEnd + Len(tagStart) + Len(tagEnd)
    lngStart = 0

End Sub

在斜体字符串周围插入标签

Insert tags around italicized strings

xml

excel

vba