EXCEL里面一次性导入大量的带表格的word文档（利于后期数据分析）

主要思路，1.EXCEL制作VB脚本。2.运行宏。3.选择word文档路径。

1.打开EXCEL软件，步骤如下：

把下面的代码复制到模块里面，最后点击步骤8保存。

Sub ImportWordTablesToExcel()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim fd As FileDialog
    Dim strFolder As String
    Dim strFile As String
    Dim ws As Worksheet
    Dim tbl As Object
    Dim rowNum As Long
    Dim colNum As Integer
    Dim cellValue As String
    
    ' 创建工作表
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Imported Data")
    If Not ws Is Nothing Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = "Imported Data"
    rowNum = 1
    
    ' 初始化Word应用程序
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo ErrorHandler
    wdApp.Visible = False
    
    ' 选择文件夹对话框
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "请选择包含Word文档的文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox "未选择文件夹，操作已取消。", vbInformation
            Exit Sub
        End If
        strFolder = .SelectedItems(1)
    End With
    
    ' 检查路径格式
    If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
    
    ' 遍历文件夹中的Word文档（支持.doc和.docx）
    strFile = Dir(strFolder & "*.doc*")
    Do While strFile <> ""
        Set wdDoc = wdApp.Documents.Open(strFolder & strFile)
        
        ' 检查文档是否有表格
        If wdDoc.Tables.Count > 0 Then
            Set tbl = wdDoc.Tables(1)
            
            ' 添加文件名标识
            ws.Cells(rowNum, 1) = strFile
            
            ' 提取表格数据
            colNum = 2  ' 从第二列开始
            For Each cell In tbl.Range.Cells
                cellValue = Replace(Replace(cell.Range.Text, Chr(13), ""), Chr(7), "")
                ws.Cells(rowNum, colNum) = Trim(cellValue)
                colNum = colNum + 1
            Next cell
            
            rowNum = rowNum + 1
        Else
            MsgBox "文档 [" & strFile & "] 中没有找到表格，已跳过。", vbExclamation
        End If
        
        wdDoc.Close False
        strFile = Dir()
    Loop
    
Cleanup:
    ' 清理对象
    If Not wdApp Is Nothing Then
        wdApp.Quit
        Set wdDoc = Nothing
        Set wdApp = Nothing
    End If
    
    ' 调整列宽
    If Not ws Is Nothing Then
        ws.Columns.AutoFit
        ws.Range("A1").EntireRow.Insert
        ws.Range("A1") = "文件名"
        ws.Range("A1").Font.Bold = True
    End If
    
    MsgBox "已完成导入 " & (rowNum - 1) & " 个文档的数据！", vbInformation
    Exit Sub
    
ErrorHandler:
    MsgBox "发生错误：" & Err.Description, vbCritical
    Resume Cleanup
End Sub

回到EXcel界面，按下操作：

点击执行后，选择自己的word文件夹即可自动导入所有word文件。