如何从Word文件提取页眉页脚存入数组并导出至Excel工作表

Sub CaptureWordHeadersFooters()
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim folderPath As String
    Dim fileName As String
    Dim resultArr() As Variant
    Dim rowIndex As Integer
    Dim newSheet As Worksheet
    
    ' 替换为你的目标文件夹路径
    folderPath = "C:\Your\Target\Folder\"
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    ' 初始化数组，先存表头
    rowIndex = 1
    ReDim resultArr(1 To rowIndex, 1 To 3)
    resultArr(rowIndex, 1) = "文件名"
    resultArr(rowIndex, 2) = "页眉内容"
    resultArr(rowIndex, 3) = "页脚内容"
    
    ' 后台启动Word，不显示界面
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False
    
    ' 遍历文件夹里的docx文件
    fileName = Dir(folderPath & "*.docx")
    Do While fileName <> ""
        rowIndex = rowIndex + 1
        ' 动态扩展数组，保留已有数据
        ReDim Preserve resultArr(1 To rowIndex, 1 To 3)
        
        ' 记录当前文件名
        resultArr(rowIndex, 1) = fileName
        
        ' 捕获文件打开失败的情况（比如文件被占用）
        On Error Resume Next
        Set wordDoc = wordApp.Documents.Open(folderPath & fileName)
        On Error GoTo 0
        
        If Not wordDoc Is Nothing Then
            ' 取第一节的默认页眉，有特殊需求可调整Sections/Headers索引
            resultArr(rowIndex, 2) = Trim(wordDoc.Sections(1).Headers(1).Range.Text)
            ' 取第一节的默认页脚
            resultArr(rowIndex, 3) = Trim(wordDoc.Sections(1).Footers(1).Range.Text)
            
            ' 关闭文档，不保存修改
            wordDoc.Close SaveChanges:=False
            Set wordDoc = Nothing
        Else
            ' 文件打不开时标记提示
            resultArr(rowIndex, 2) = "文件无法打开"
            resultArr(rowIndex, 3) = "文件无法打开"
        End If
        
        fileName = Dir()
    Loop
    
    ' 关闭Word并释放资源，避免后台残留进程
    wordApp.Quit
    Set wordApp = Nothing
    
    ' 在当前工作簿新建工作表
    Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    newSheet.Name = "页眉页脚记录"
    
    ' 把数组一次性写入工作表，效率比逐行写高
    newSheet.Range("A1").Resize(UBound(resultArr, 1), UBound(resultArr, 2)).Value = resultArr
    
    ' 自动调整列宽
    newSheet.Columns("A:C").AutoFit
    
    MsgBox "数据提取完成！", vbInformation
End Sub

• 动态数组用法：因为不知道文件夹里有多少Word文件，用ReDim Preserve每次遍历到新文件就扩展数组行数，同时保留之前存的数据，不会丢失已提取的内容。
• Word对象操作：
  • 后台启动Word（Visible = False）避免弹出界面干扰；
  • Sections(1).Headers(1)对应文档第一节的默认页眉，如果文档有分节、奇偶页不同设置，可调整索引：比如Headers(2)是第一页专属页眉，Headers(3)是奇偶页页眉；
  • 用Trim()去掉页眉页脚文本末尾的特殊格式字符，避免出现多余空白。
• 错误处理：加On Error Resume Next防止因文件损坏、被占用导致程序直接崩溃，同时标记异常文件。
• 资源释放：用完Word文档和应用后必须关闭并释放对象，不然Word进程会一直在后台跑，占用内存。

1. 如果要兼容.doc格式，把Dir(folderPath & "*.docx")改成Dir(folderPath & "*.doc*")；
2. 若要提取所有节的页眉页脚，可加循环遍历wordDoc.Sections；
3. 如需区分奇偶页页眉，把Headers(1)换成Headers(3)（对应wdHeaderFooterEvenPages）。

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