Teams转录格式化VBA宏问题：Q)后语句未按预期加粗

问题描述 #

我编写了用于格式化Teams转录文本的VBA宏，需求为：Q)及其后续语句需加粗，A)需加粗但后续语句不加粗。但当前运行宏后，仅Q)和A)实现加粗，Q)后的语句未达到加粗效果，请求排查宏代码中的问题。

原VBA代码 #

Public Sub MsNewTeamsVersion()

On Error Resume Next


    Dim doc As Document
    Set doc = ActiveDocument

    ' Regular expressions for matching timestamps and speaker names
    Dim regexTimestamp As RegExp
    Dim regexName As RegExp

    Dim match As Object
    Dim matches As Object

    Dim lines() As String
    Dim isOIGSpeaker As Boolean
    Dim hasTimestamp As Boolean
    Dim sentence As Object

    Dim i As Integer

    Set regexTimestamp = New RegExp
    Set regexName = New RegExp

    ' Pattern to match timestamps in the format [HH:MM]
    'regexTimestamp.pattern = "?([0-9]{1})?:([0-9]{1,2}:[0-9]{2})"
    regexTimestamp.pattern = "(?:(\d{1,2}):)?(\d{1,2}):(\d{2})"
    regexTimestamp.Global = True

    ' Pattern to match speaker names ending with (OIG)
    regexName.pattern = "(\w+\W\s\w+\s\(OIG\))"
    regexName.Global = True

    ' Remove shapes
    Call RemoveShapes

    ' Remove carriage returns
    doc.Content.text = Replace(doc.Content.text, Chr(11), " ")
    doc.Content.Bold = False

    ' Look for timestamps
    Set matches = regexTimestamp.Execute(doc.Content.text)

    ' Loop through timestamps and now insert a new line
    ' The previous code collapses everything to one paragraph and
    ' this makes sure the headers have a space after it.
    For Each match In matches
        doc.Content.text = Replace(doc.Content.text, match.Value, match.Value & vbNewLine)
    Next match

    'Loop through each paragraph
    For Each para In doc.paragraphs

        'Split lines in paragraph
        lines() = Split(para.Range.text, Chr(11)) ' Split paragraph into lines

        'Initialize loopers
        i = 0

        'Initialize booleans
        isOIGSpeaker = False
        hasTimestamp = False

        'Loop through lines in paragraph
        For Each Line In lines
            Set sentence = para.Range.paragraphs(1).Range.Duplicate ' Set "sentence" to the current line
            sentence.Start = para.Range.Start + InStr(para.Range.text, Line) - 1
            sentence.End = sentence.Start + Len(Line)

            'Check is speaker is OIG in line
            isOIGSpeaker = CheckOIGSpeaker(sentence.text)

            'Check if timestamp in line
            hasTimestamp = CheckTimeStamp(sentence.text)

            'Based on if OIG and if has timestamp, process accordingly
            If isOIGSpeaker = True And hasTimestamp = True Then
                sentence.Font.Bold = True
                sentence.InsertAfter vbNewLine & "Q) "
            ElseIf isOIGSpeaker = False And hasTimestamp = True Then
                sentence.Font.Bold = True
                sentence.InsertAfter vbNewLine & "A) "
            Else
                sentence.Font.Bold = False
            End If

            'Increment looper
            i = i + 1
        Next Line
    Next para

    Call BoldAll("Q)")
    Call BoldAll("A)")
    Call ReplaceDoubleParagraphs

    'Call ReplaceTimeWithDurations

    'Cleanup
    Set sentence = Nothing
    Set match = Nothing
    Set matches = Nothing
    Set regexTimestamp = Nothing
    Set regexName = Nothing

End Sub

Private Sub BoldAll(text As String)

    With ActiveDocument.Content.Find
        .ClearFormatting
        ' Substitute the text you want to make bold
        .text = text
        .Replacement.ClearFormatting
        .Replacement.Font.Bold = True
        .Replacement.text = "^&"
        .Format = True
        .Forward = True
        .Wrap = wdFindStop
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
End Sub



Private Function CheckOIGSpeaker(text As String) As Boolean

    'This function checks if there is an OIG Speaker

    Dim regexName As RegExp
    Set regexName = New RegExp

    With regexName
        .pattern = "(\w+\W\s\w+\s\(OIG\))"
        .Global = True
        .IgnoreCase = True
        If .test(text) Then
            CheckOIGSpeaker = True
        Else
            CheckOIGSpeaker = False
        End If
    End With

End Function

Private Function CheckTimeStamp(text As String) As Boolean

    'This function checks if there is a timestamp in the text

    Dim regexTimestamp As RegExp

    Set regexTimestamp = New RegExp

    With regexTimestamp
        '.pattern = "?([0-9]{1})?:([0-9]{1,2}:[0-9]{2})"
        .pattern = "(?:(\d{1,2}):)?(\d{1,2}):(\d{2})"
        .Global = True
        .IgnoreCase = True
        If .test(text) Then
            CheckTimeStamp = True
        Else
            CheckTimeStamp = False
        End If
    End With

End Function


Private Sub RemoveShapes()

    'This method removes all shapes

    For i = ActiveDocument.Shapes.Count To 1 Step -1
        ActiveDocument.Shapes(i).Delete
    Next i

End Sub

Private Function FindRegexMatches(text As String, pattern As String) As Object

    Dim rx As RegExp

    Set rx = New RegExp

    With rx
        .pattern = pattern
        .Global = True
        .IgnoreCase = True
        Set FindRegexMatches = rx.Execute(text)
    End With


End Function

Private Sub ReplaceTimeWithDurations()

    Dim doc As Document
    Dim match As Object
    Dim matches As Object
    Dim prevMatchVal As Date
    Dim prevMatchText As String
    Dim strDuration As String

    Set doc = ActiveDocument

    prevMatchText = Format("00:00:00", "HH:MM:SS")
    prevMatchValue = TimeValue(prevMatchText)

    Set matches = FindRegexMatches(doc.Content.text, "([0-9]{1,2}:[0-9]{2})")

    For Each match In matches
        strDuration = prevMatchText & " - " & Format(TimeValue(Format(match.Value, "HH:MM:SS")) + prevMatchValue, "HH:MM:SS")
        prevMatchValue = TimeValue(Format(match.Value, "HH:MM:SS")) + prevMatchValue
        prevMatchText = Format(prevMatchValue, "HH:MM:SS")
        'doc.Content.text = Replace(doc.Content.text, match.Value, strDuration, 1, 1, vbBinaryCompare)
        With doc.Content.Find
            .text = match.Value
            .Replacement.text = strDuration
            .Format = True
            .Execute Replace:=wdReplaceOne
        End With
    Next match



End Sub
Private Sub ReplaceDoubleParagraphs()
    ' Find and replace double paragraph marks with single paragraph marks
    With Selection.Find
        .text = "^p^p"
        .Replacement.text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With

    ' Execute the replacement
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

问题根源 #

1. 缺少上下文状态追踪：代码没有记录当前是否处于Q)的内容段落，导致所有非时间戳行都被强制设为非加粗（Else分支的sentence.Font.Bold = False），直接覆盖了Q)后续语句的加粗需求。
2. 行范围定位错误：Set sentence = para.Range.paragraphs(1).Range.Duplicate始终指向段落的第一行，而非当前遍历的行，导致格式应用范围错误。
3. 拆分逻辑不匹配：用Chr(11)拆分段落，但之前插入的是vbNewLine，导致行识别混乱。

修复后的代码 #

修改核心的段落循环逻辑，添加状态变量追踪Q)上下文，同时修正行范围定位：

Public Sub MsNewTeamsVersion()

On Error Resume Next

    Dim doc As Document
    Set doc = ActiveDocument

    ' Regular expressions for matching timestamps and speaker names
    Dim regexTimestamp As RegExp
    Dim regexName As RegExp

    Dim match As Object
    Dim matches As Object

    Dim lines() As String
    Dim isOIGSpeaker As Boolean
    Dim hasTimestamp As Boolean
    Dim sentence As Range ' 改为Range类型更准确
    Dim isQContext As Boolean ' 新增：追踪是否处于Q)的内容上下文

    Dim i As Integer

    Set regexTimestamp = New RegExp
    Set regexName = New RegExp

    ' Pattern to match timestamps in the format [HH:MM]
    regexTimestamp.pattern = "(?:(\d{1,2}):)?(\d{1,2}):(\d{2})"
    regexTimestamp.Global = True

    ' Pattern to match speaker names ending with (OIG)
    regexName.pattern = "(\w+\W\s\w+\s\(OIG\))"
    regexName.Global = True

    ' Remove shapes
    Call RemoveShapes

    ' Remove carriage returns
    doc.Content.Text = Replace(doc.Content.Text, Chr(11), " ")
    doc.Content.Bold = False

    ' Look for timestamps and insert new lines
    Set matches = regexTimestamp.Execute(doc.Content.Text)
    For Each match In matches
        doc.Content.Text = Replace(doc.Content.Text, match.Value, match.Value & vbNewLine)
    Next match

    'Loop through each paragraph
    isQContext = False ' 初始化上下文状态
    For Each para In doc.Paragraphs
        'Split lines in paragraph
        lines() = Split(para.Range.Text, vbNewLine) ' 改用vbNewLine拆分，匹配之前插入的换行符

        'Loop through lines in paragraph
        For Each Line In lines
            If Trim(Line) = "" Then GoTo NextLine ' 跳过空行

            ' 准确定位当前行的Range
            Set sentence = para.Range.Duplicate
            sentence.Start = para.Range.Start + InStr(para.Range.Text, Line) - 1
            sentence.End = sentence.Start + Len(Line)

            'Check is speaker is OIG in line
            isOIGSpeaker = CheckOIGSpeaker(sentence.Text)

            'Check if timestamp in line
            hasTimestamp = CheckTimeStamp(sentence.Text)

            'Based on if OIG and if has timestamp, process accordingly
            If isOIGSpeaker = True And hasTimestamp = True Then
                sentence.Font.Bold = True
                sentence.InsertAfter vbNewLine & "Q) "
                isQContext = True ' 进入Q)上下文
            ElseIf isOIGSpeaker = False And hasTimestamp = True Then
                sentence.Font.Bold = True
                sentence.InsertAfter vbNewLine & "A) "
                isQContext = False ' 退出Q)上下文
            Else
                ' 根据当前上下文决定是否加粗
                sentence.Font.Bold = isQContext
            End If

NextLine:
        Next Line
    Next para

    Call BoldAll("Q)")
    Call BoldAll("A)")
    Call ReplaceDoubleParagraphs

    'Cleanup
    Set sentence = Nothing
    Set match = Nothing
    Set matches = Nothing
    Set regexTimestamp = Nothing
    Set regexName = Nothing

End Sub

' 以下其他函数/子程序保持不变，省略重复代码

关键修改点 #

• 新增isQContext布尔变量，用来追踪当前是否处于Q)的内容段落；
• 修正行Range的定位逻辑，确保每次处理的是当前遍历的行；
• 调整Else分支的加粗逻辑，不再强制设为False，而是根据isQContext的值决定是否加粗；
• 改用vbNewLine拆分段落行，适配之前插入的换行符；
• 添加空行跳过逻辑，避免处理无效内容。

内容的提问来源于stack exchange，提问作者J.M Hanlon