VBA条件定位Word页面：提取指定页面表格至Excel工作表

针对你遇到的Word文档格式不统一、目标表格位置不固定的问题，我写了一段实用的VBA脚本，可以逐页扫描文档，定位包含material或material list关键词的页面，然后提取该页的表格到Excel工作表中。

核心思路 #

• 逐页遍历Word文档，精准获取每页的文本范围
• 在每页范围内搜索指定关键词（不区分大小写，支持模糊匹配）
• 一旦找到关键词，提取该页内的目标表格（根据你的描述，每页仅含一个目标表格）
• 将表格复制到Excel指定工作表，自动追加到已有内容下方

完整VBA代码 #

Sub ExtractMaterialTablesToExcel()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdPageRange As Object
    Dim wdTable As Object
    Dim xlSheet As Worksheet
    Dim lastRow As Long
    Dim pageCount As Integer
    Dim keywordFound As Boolean
    
    ' 设置Excel目标工作表（可自行修改为你的工作表名称）
    Set xlSheet = ThisWorkbook.Worksheets("Sheet1")
    
    ' 初始化Word对象，后台运行不显示界面
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False
    ' 替换为你的Word文件实际路径
    Set wdDoc = wdApp.Documents.Open("C:\Your\Target\File.docx")
    
    ' 获取Word文档总页数
    pageCount = wdDoc.ComputeStatistics(2) ' 2对应wdStatisticPages常量
    
    ' 逐页遍历文档
    For i = 1 To pageCount
        ' 跳转到当前页，获取页面范围
        wdApp.Selection.GoTo What:=1, Which:=2, Name:=i ' 1=wdGoToPage, 2=wdGoToAbsolute
        Set wdPageRange = wdDoc.Bookmarks("\Page").Range
        
        ' 在当前页内搜索关键词，支持匹配material或material list
        With wdPageRange.Find
            .Text = "material*list"
            .MatchWildcards = True
            .MatchCase = False
            .Forward = True
            .Wrap = 0 ' 0=wdFindStop，限制在当前页查找
            keywordFound = .Execute
        End With
        
        ' 找到关键词后提取表格
        If keywordFound Then
            ' 遍历当前页的表格（每页仅一个的话循环只执行一次）
            For Each wdTable In wdPageRange.Tables
                ' 定位Excel下一个空白行
                lastRow = xlSheet.Cells(xlSheet.Rows.Count, 1).End(xlUp).Row + 1
                ' 复制Word表格并粘贴到Excel（保留原格式）
                wdTable.Range.Copy
                xlSheet.Range("A" & lastRow).PasteSpecial Paste:=10 ' 10=xlPasteAllUsingSourceTheme
                ' 表格间留空行，避免重叠
                lastRow = xlSheet.Cells(xlSheet.Rows.Count, 1).End(xlUp).Row + 2
            Next wdTable
        End If
    Next i
    
    ' 清理对象，释放内存
    wdDoc.Close SaveChanges:=False
    wdApp.Quit
    Set wdTable = Nothing
    Set wdPageRange = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set xlSheet = Nothing
    
    MsgBox "表格提取完成！", vbInformation
End Sub

关键细节说明 #

1. 按页遍历的实现：通过ComputeStatistics获取总页数，再用Selection.GoTo跳转到指定页面，结合Bookmarks("\Page").Range锁定当前页范围，确保关键词搜索不会跨页。
2. 灵活的关键词匹配：启用通配符后，material*list可以匹配material、material list甚至中间带空格/符号的类似文本，同时关闭大小写匹配，适配不同的文档格式。
3. 格式保留的粘贴：使用PasteSpecial的xlPasteAllUsingSourceTheme参数，确保Word表格的格式完整复制到Excel中。
4. 后台运行优化：设置wdApp.Visible = False让Word在后台执行，避免操作过程中干扰你的正常工作。

使用注意事项 #

• 务必替换代码中的Word文件路径为你实际的文件路径
• 确认Excel目标工作表名称与代码中的一致（默认是Sheet1，可按需修改）
• 如果目标页存在多个表格，脚本会全部提取，若只需第一个表格，可在遍历表格时添加Exit For跳出循环

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