批量提取word表格数据到一个excel

1. 新建一个excel到word同级目录
2. alt+f11打开vba窗口并新建模块
3. 粘贴下方代码（修改一些必要参数）
4. 回到excel表格界面，alt+f8选择执行该宏
5. 注意要在信任中心开启运行vba宏

Sub 批量提取word表格数据到excel()Dim wdApp As Object, wdDoc As ObjectDim fso As Object, folder As Object, file As ObjectDim excelRow As Long, iRow As Long, iCol As IntegerDim tableNo As IntegerDim folderPath As String    tableNo = 1 ' 修改为实际表格序号，默认第一个表格excelRow = 1 ' Excel起始行folderPath = ActiveWorkbook.Path & "\" ' word文件所在目录' 创建文件系统对象Set fso = CreateObject("Scripting.FileSystemObject")Set folder = fso.GetFolder(folderPath)' 初始化WordOn Error Resume NextSet wdApp = GetObject(, "Word.Application")If Err.Number <> 0 ThenSet wdApp = CreateObject("Word.Application")End IfOn Error GoTo 0wdApp.Visible = False ' 隐藏Word窗口' 遍历文件夹中的每个Word文档For Each file In folder.FilesIf (fso.GetExtensionName(file.Path) = "doc") Or (fso.GetExtensionName(file.Path) = "docx") ThenSet wdDoc = wdApp.Documents.Open(file.Path)' 检查文档中是否存在表格If wdDoc.Tables.Count >= tableNo ThenWith wdDoc.Tables(tableNo)' 复制表格数据到Excel' 1.遍历姓名For iRow = 5 To 5For iCol = 2 To 2' 去除换行符和空格并写入ExcelCells(excelRow, iCol - 1).Value = WorksheetFunction.Clean(Replace(.Cell(iRow, iCol).Range.Text, vbCr, ""))Next iColexcelRow = excelRow + 1Next iRow' 2.遍历成绩For iRow = 3 To 3For iCol = 5 To 5' 去除换行符和空格并写入ExcelCells(excelRow - 1, iCol - 3).Value = WorksheetFunction.Clean(Replace(.Cell(iRow, iCol).Range.Text, vbCr, ""))Next iColexcelRow = excelRowNext iRow' 3.遍历其他数据信息' ' ' ' ' ' ' End WithEnd IfwdDoc.Close SaveChanges:=FalseEnd IfNext file' 清理缓存数据wdApp.QuitSet wdDoc = NothingSet wdApp = NothingSet fso = NothingMsgBox "提取完毕！找到文件数量：" & folder.Files.Count-2
End Sub