请求开发从Word指定表格行列提取数据至Excel的Macro

宏功能 #

根据Excel第2行单元格中指定的Word文件路径、表格序号、行号、列号，自动提取对应单元格的数据并替换原单元格内容。

使用步骤 #

1. 打开你的Excel文件，按Alt + F11打开VBA编辑器
2. 右键点击左侧的工作簿名称，选择「插入」→「模块」
3. 将下方的VBA代码粘贴到模块窗口中
4. 在Excel第2行的单元格中按格式填写提取规则：完整Word文件路径|表格序号|行号|列号（示例：C:\Docs\合同.docx|1|3|2，代表从该Word的第1个表格第3行第2列提取数据）
5. 回到VBA编辑器按F5运行宏，或在Excel「开发工具」选项卡中点击「宏」选择ExtractFromWordTable运行

VBA代码 #

Sub ExtractFromWordTable()
    Dim ws As Worksheet
    Dim cell As Range
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim tableNum As Integer, rowNum As Integer, colNum As Integer
    Dim wordPath As String
    Dim cellContent As String
    Dim parts As Variant
    
    ' 操作当前活动工作表，可改为指定工作表如Set ws = ThisWorkbook.Sheets("Sheet1")
    Set ws = ActiveSheet
    
    ' 后台启动Word
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False
    
    ' 遍历第2行所有非空单元格
    For Each cell In ws.Rows(2).Cells
        cellContent = Trim(cell.Value)
        If cellContent <> "" Then
            ' 拆分提取规则
            parts = Split(cellContent, "|")
            If UBound(parts) = 3 Then
                wordPath = Trim(parts(0))
                tableNum = CInt(Trim(parts(1)))
                rowNum = CInt(Trim(parts(2)))
                colNum = CInt(Trim(parts(3)))
                
                ' 检查文件是否存在
                If Dir(wordPath) <> "" Then
                    On Error Resume Next
                    Set wordDoc = wordApp.Documents.Open(wordPath)
                    On Error GoTo 0
                    
                    If Not wordDoc Is Nothing Then
                        ' 验证表格、行、列是否存在
                        If tableNum <= wordDoc.Tables.Count Then
                            With wordDoc.Tables(tableNum)
                                If rowNum <= .Rows.Count And colNum <= .Columns.Count Then
                                    ' 提取数据并去除Word单元格末尾的特殊标记
                                    cell.Value = Left(.Cell(rowNum, colNum).Range.Text, Len(.Cell(rowNum, colNum).Range.Text) - 2)
                                Else
                                    cell.Value = "行/列超出范围"
                                End If
                            End With
                        Else
                            cell.Value = "表格不存在"
                        End If
                        wordDoc.Close SaveChanges:=False
                        Set wordDoc = Nothing
                    Else
                        cell.Value = "无法打开Word文件"
                    End If
                Else
                    cell.Value = "Word文件不存在"
                End If
            Else
                cell.Value = "格式错误，需遵循：路径|表格号|行号|列号"
            End If
        End If
    Next cell
    
    ' 关闭Word
    wordApp.Quit
    Set wordApp = Nothing
    
    MsgBox "提取完成！"
End Sub

注意事项 #

• 运行前关闭目标Word文档，避免文件被占用
• 若Excel提示宏被禁用，需在「文件→选项→信任中心→信任中心设置→宏设置」中选择「启用所有宏」（仅信任文件时使用）
• 表格、行、列的序号均从1开始计数
• 如果需要更换分隔符，修改代码中Split(cellContent, "|")的|为你想要的符号即可

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