如何高效将含访谈转录文本的Word文档解析为Excel列

需求说明 #

• 批量读取多个Word访谈转录文档，仅提取目标受访者的对话内容
• 将数据整理为结构化表格，包含Title、DateTime、TimeStamp、Speaker、Text五列
• 采用数组收集数据后一次性写入Excel，替代逐段复制粘贴，提升运行效率

修改后的VBA代码 #

Option Explicit

Sub ParseTranscriptToExcelSheet()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim para As Object
    Dim oFileDialog As FileDialog
    Dim vSelectedItem As Variant
    
    Dim ws2 As Worksheet
    Dim outputArr() As Variant
    Dim arrIndex As Long
    Dim currentTitle As String, currentDateTime As String, targetSpeaker As String
    Dim currentTimestamp As String
    
    Set ws2 = ThisWorkbook.Sheets(2)
    ' 重置Sheet2内容并设置表头
    ws2.Cells.Clear
    ws2.Range("A1:E1").Value = Array("Title", "DateTime", "Timestamp", "Speaker", "Text")
    arrIndex = 1 ' 数组索引从1开始，对应Excel第2行数据
    
    ' 初始化Word应用
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    On Error GoTo 0
    If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False
    
    ' 打开文件选择对话框
    Set oFileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With oFileDialog
        .Title = "选择Word文件"
        .AllowMultiSelect = True
        .Filters.Add "Word文件", "*.doc*", 1
        If .Show = -1 Then
            ' 预分配数组初始容量，避免频繁扩容
            ReDim outputArr(1 To 1000, 1 To 5)
            
            For Each vSelectedItem In .SelectedItems
                Set wdDoc = wdApp.Documents.Open(vSelectedItem)
                ' 重置当前文档的变量
                currentTitle = ""
                currentDateTime = ""
                targetSpeaker = ""
                currentTimestamp = ""
                
                For Each para In wdDoc.Paragraphs
                    Dim paraText As String
                    paraText = Trim(para.Range.Text)
                    ' 移除Word段落标记
                    paraText = Left(paraText, Len(paraText) - 1)
                    
                    Select Case True
                        ' 提取文档标题（非括号开头的首段有效内容）
                        Case currentTitle = "" And paraText <> "" And Not paraText Like "(*"
                            currentTitle = paraText
                        ' 提取访谈日期时间（括号包裹且包含时间格式的内容）
                        Case currentDateTime = "" And paraText Like "(????*" And paraText Like "*-*:*"
                            currentDateTime = paraText
                        ' 提取目标受访者名称
                        Case targetSpeaker = "" And paraText Like "(Interviewee:*"
                            targetSpeaker = Replace(Replace(paraText, "(Interviewee: ", ""), ")", "")
                            targetSpeaker = Trim(targetSpeaker)
                        ' 提取对话时间戳
                        Case paraText Like "(00:*"
                            currentTimestamp = paraText
                        ' 提取目标受访者的对话内容
                        Case InStr(paraText, ":") > 0
                            Dim speaker As String, textContent As String
                            speaker = Trim(Left(paraText, InStr(paraText, ":") - 1))
                            textContent = Trim(Mid(paraText, InStr(paraText, ":") + 1))
                            
                            If speaker = targetSpeaker And textContent <> "" Then
                                arrIndex = arrIndex + 1
                                ' 数组容量不足时自动扩容
                                If arrIndex > UBound(outputArr, 1) Then
                                    ReDim Preserve outputArr(1 To UBound(outputArr, 1) + 500, 1 To 5)
                                End If
                                ' 填充数据：仅当前文档第一条对话保留标题和日期
                                outputArr(arrIndex, 1) = IIf(arrIndex = 2, currentTitle, "")
                                outputArr(arrIndex, 2) = IIf(arrIndex = 2, currentDateTime, "")
                                outputArr(arrIndex, 3) = currentTimestamp
                                outputArr(arrIndex, 4) = speaker
                                outputArr(arrIndex, 5) = textContent
                            End If
                    End Select
                Next para
                
                wdDoc.Close savechanges:=False
            Next vSelectedItem
            
            ' 将数组数据一次性写入Excel
            If arrIndex > 1 Then
                ws2.Range("A2:E" & arrIndex).Value = outputArr(2 To arrIndex, 1 To 5)
            End If
        Else
            MsgBox "未选择任何文件"
        End If
    End With
    
    ' 清理对象
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set ws2 = Nothing
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "处理完成！"
End Sub

核心优化点 #

• 数组批量写入：替代逐段复制粘贴操作，将所有符合条件的数据存入数组后一次性写入Excel，大幅降低系统开销
• 精准内容匹配：通过段落特征（格式、关键词）自动识别标题、日期、受访者、时间戳和对话，仅保留目标受访者的内容
• 动态数组扩容：预分配初始数组容量，当数据超出时自动扩容，避免频繁ReDim Preserve影响效率
• 资源优化：关闭Word可见性、禁用Excel屏幕更新，减少不必要的系统资源消耗

内容的提问来源于stack exchange，提问作者sifar