批量处理word中的表格到excel中

• 选择工具中的开发工具

注意：设计模式下，选中按钮，点击右键，命令按钮对象的编辑功能可修改按钮的名称。

3. 在vb编辑绑定的方法中开始编写整个业务逻辑，流程如下图所示

三、效果展示

同一目录中准备如下文档，如下。

统计表格初始样式如下图所示，由于我期望整体表格采用统一的样式，因此表格主题留出两行，以便复制插入行时，保持样式一致；从图中可以看出，目前表格尚没有数据，故数据插入行号为3、统计开始序号为1。

点击统计按钮，开始统计当前目录中word文档中的表格，目前已知有三个word文档中都记录了一个表格（每个表格有6行，包含标题），统计后结果如下。

四、VB代码

Private Sub data_statistics_Click()    ' 声明变量    Dim wdApp As Object, wdDoc As Object    Dim xlWs As Worksheet    Dim strFolderPath As String, strFileName As String    Dim lngRow, docNum As Long    Dim i As Long, j As Long, k As Long    Dim cellContent As String    ' 设置Excel中用于输出的工作表    Set xlWs = ActiveSheet    ' 获取当前工作簿所在目录    strFolderPath = ThisWorkbook.Path & "\"    ' 清空目标工作表内容    ' xlWs.Cells.Clear    ' 初始化行号    lngRow = xlWs.Range("N1").Text - 2    docNum = xlWs.Range("N2").Text - 1    ' 获取文件夹下所有Word文档    strFileName = Dir(strFolderPath & "*.doc*")    Application.ScreenUpdating = False    Application.DisplayAlerts = False    ' 遍历所有Word文档    Do While strFileName <> ""        docNum = docNum + 1        ' 创建Word应用程序对象        Set wdApp = CreateObject("Word.Application")        wdApp.Visible = False        Set wdDoc = wdApp.Documents.Open(strFolderPath & strFileName)        ' 遍历文档中的所有表格        For i = 1 To wdDoc.Tables.Count            sumRow = wdDoc.Tables(i).Rows.Count            sumColumns = wdDoc.Tables(i).Columns.Count            Debug.Print strFileName & "共有" & i & "表格，该表格共有：" & sumRow; "行，" & sumColumns; "列"            ' 循环插入多行            xlWs.Rows(lngRow + 2).Copy            For j = 0 To sumRow - 2 '表格的总行数减去1，因此不算标题行，由于从0开始，因此又减去1                xlWs.Rows(lngRow + 3).Insert Shift:=xlDown            Next j            For Each cell In wdDoc.Tables(i).Range.Cells                ' Debug.Print cell.Range.Text & "的行号为：" & cell.RowIndex & " 列号为：" & cell.ColumnIndex                ' 获取单元格内容                cellContent = Application.WorksheetFunction.Clean(cell.Range.Text)                cellContent = Replace(cellContent, Chr(7), "")                cellContent = Replace(cellContent, Chr(13), "")                ' 将内容写入Excel                If Not IsEmpty(cellContent) And cell.RowIndex <> 1 Then                    If cell.RowIndex = 2 Then                        xlWs.Cells(cell.RowIndex + lngRow, 1).Value = docNum                    End If                    xlWs.Cells(cell.RowIndex + lngRow, cell.ColumnIndex + 1).Value = cellContent                End If            Next cell            '合并当前excel文档对应行数的a列，b列和c列            Set targetRange_A = Range(Cells(lngRow + 2, 1), Cells(lngRow + sumRow - 1, 1))            Set targetRange_B = Range(Cells(lngRow + 2, 2), Cells(lngRow + sumRow - 1, 2))            Set targetRange_C = Range(Cells(lngRow + 2, 3), Cells(lngRow + sumRow - 1, 3))            ' 合并单元格            targetRange_A.Merge            targetRange_B.Merge            targetRange_C.Merge            ' 设置合并后单元格内容居中对齐            With targetRange_A                .VerticalAlignment = xlCenter                .HorizontalAlignment = xlCenter            End With            With targetRange_B                .VerticalAlignment = xlCenter                .HorizontalAlignment = xlCenter            End With            With targetRange_C                .VerticalAlignment = xlCenter                .HorizontalAlignment = xlCenter            End With            '计算下一个文档开始行            lngRow = lngRow + sumRow - 1            xlWs.Range(Cells(lngRow + 1, 1), Cells(lngRow + 1, 9)).Interior.Color = RGB(230, 238, 221)            xlWs.Range(Cells(lngRow + 1, 1), Cells(lngRow + 1, 9)).Font.Bold = True            xlWs.Range(Cells(lngRow + 1, 1), Cells(lngRow + 1, 9)).Borders.LineStyle = xlNone            xlWs.Range(Cells(lngRow + 1, 1), Cells(lngRow + 1, 9)).BorderAround LineStyle:=xlContinuous            xlWs.Cells(lngRow + 1, 5).Value = 0            xlWs.Cells(lngRow + 1, 5).Font.Color = RGB(230, 238, 221)        Next i        ' 关闭当前Word文档        wdDoc.Close SaveChanges:=False        Set wdDoc = Nothing        ' 获取下一个文件名        strFileName = Dir()    Loop    ' 退出Word应用程序    wdApp.Quit    Set wdApp = Nothing    ' 恢复Excel设置    Application.ScreenUpdating = True    Application.DisplayAlerts = True    MsgBox "完成!共处理了 " & lngRow & " 行数据。"End Sub