VBA将Word表格中的内容导入已有Excel工作薄中

---

背景

由于近期有将Word中的表格导入到Excel中的需求，于是利用Word VBA来解决。

---

问题描述

Word中的表格有规律，两个表格为一个信息组，且两个中的第一个表格的前两行位置处的内容为表格标题。现在需要在已有Excel工作薄中新建工作表，将Word中一个信息组（即Word中两个表格为一组）中的内容导入到新建工作表中的指定位置，且新建工作表表名为Word中的表格标题。

---

官方文档

Office VBA 参考
官方文档是最好的学习资料，把自己的需求对照里面查找，就能实现自己想要的功能。

---

代码运行的前提

因为涉及到Excel中的对象，所以需要引用。引用分为两种：一种是前期引用，也就是在“工具”菜单下的“引用”命令中添加Excel库；另一种CreateObject语句添加后期引用。两者各有优劣，这次使用的是前期引用。

---

代码实现

Sub ReturnCellContentToRange()
  Dim iFlag As Integer '标志符，用来判断单数个表还是偶数个表
  Dim myTable As Table '定义Word中Table对象
  Dim strCells() As String '定义数组
  Dim iRow, iColumn, r, c As Integer '定义所需要的整型变量
' **********Word中Range对象表示文档中的一个连续区域。 每个 Range 对象由一个起始字符位置和一个终止字符位置定义。*********
  Dim rngText As Range '定义Word中Range对象,用来指示 位于表格前两行的表格标题，从而用它来当Excel中的新建表名
  Dim rngStart, rngEnd As Range '定义Word中Range对象，用于标定表格标题rngText的起始和终止位置
  
  Dim myBook As Workbook '定义Excel中Workbook对象
  Set myBook = Workbooks.Open(ThisDocument.Path + "\整理.xlsx") '指定myBook为当前Word所在路径中的“整理.xlsx”
  Excel.Application.ScreenUpdating = False '禁用屏幕更新可以加快宏代码的速度
  
  iFlag = 1 '标志符，用来判断单数个表还是偶数个表
  
  For Each myTable In ThisDocument.Tables '遍历该Word中的所有表格
'*******************************新建worksheet***********************************
    If iFlag Mod 2 = 1 Then '如果为奇数个表
      Set rngStart = myTable.Range '将rngStart指定为当前遍历到的Word表格中的Range对象
      Set rngEnd = myTable.Range '将rngEnd指定为当前遍历到的Word表格中的Range对象
     
      rngStart.Collapse (wdCollapseStart) '将表格标题起始位置标定到表头
      rngStart.Move Unit:=wdParagraph, Count:=-2 '将表格标题起始位置标定到表头前两段
      
      rngEnd.Collapse (wdCollapseStart) '将表格标题终止位置标定到表头
      rngEnd.Move Unit:=wdParagraph, Count:=-1 '将表格标题终止位置标定到表头前一段
      
      Set rngText = ThisDocument.Range(Start:=rngStart.End, End:=rngEnd.End) '标定表格标题rngText的起始和终止位置
      rngText.Select '将表格标题选中，方便查看
      
      myBook.Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Replace(rngText.Text, "/", "|") '将表格标题的文本当作Excel中新建worksheet的表名，Replace函数用来将不符合表名要求的字符替换掉，避免出错
    End If
    
'********************提取Word表格中的内容到Excel单元格中******************************
    iRow = myTable.Rows.Count 'Word中表格的行数
    iColumn = myTable.Columns.Count 'Word中表格的列数
    ReDim strCells(1 To iRow, 1 To iColumn) '重定义字符串数组为二维数组
    For r = 1 To iRow '遍历表格
      For c = 1 To iColumn
        On Error Resume Next '忽略错误，继续执行。原因是有些表格中的内容为图片等其它，导致出错，这里我们提取文字为主，忽略错误
        strCells(r, c) = Left(myTable.Cell(r, c).Range.Text, Len(myTable.Cell(r, c).Range.Text) - 1) '将最后一个字符剔除掉。原因是Word表格中的每个单元格中的内容最后会有一个不是文字的字符，该字符不是需要的
        
        If Err.Number = 5941 Then '如果错误代码为5941，则将赋值为空，根据实际情况来
          strCells(r, c) = ""
        End If
        
        Debug.Print r & "行" & c & "列" '打印在立即窗口，方便调试
        Debug.Print strCells(r, c) '打印在立即窗口，方便调试
        
        If iFlag Mod 2 = 1 Then
          myBook.ActiveSheet.Cells(r, c + 10) = strCells(r, c) '奇数表格从指定列开始放置
        Else
          myBook.ActiveSheet.Cells(r, c) = strCells(r, c) '偶数表格从指定列开始放置
        End If
      Next
    Next
    
'****************************Excel中的简单格式化*****************************
    myBook.ActiveSheet.Cells.EntireColumn.AutoFit '列自适应
    myBook.ActiveSheet.Cells.EntireColumn.HorizontalAlignment = xlCenter '水平居中
    myBook.ActiveSheet.Cells.EntireColumn.VerticalAlignment = xlCenter '垂直居中
    If iFlag Mod 2 = 1 Then '将已转换的单元格加上边框
      With myBook.ActiveSheet
        With .Range(.Cells(1, 11), .Cells(iRow, iColumn + 10))
          .Borders(xlDiagonalDown).LineStyle = xlNone
          .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With
            With .Borders(xlEdgeTop)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With
            With .Borders(xlEdgeBottom)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With
            With .Borders(xlEdgeRight)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With
            With .Borders(xlInsideVertical)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With   
        End With          
      End With       
    Else    
      With myBook.ActiveSheet
        With .Range(.Cells(1, 1), .Cells(iRow, iColumn))
          .Borders(xlDiagonalDown).LineStyle = xlNone
          .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With
            With .Borders(xlEdgeTop)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With
            With .Borders(xlEdgeBottom)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With
            With .Borders(xlEdgeRight)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With
            With .Borders(xlInsideVertical)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
              .LineStyle = xlContinuous
              .ColorIndex = 0
              .TintAndShade = 0
              .Weight = xlThin
            End With       
        End With          
      End With 
    End If   
    iFlag = iFlag + 1 '奇偶变换
   Next

  myBook.Save 'Excel工作薄保存
  Excel.Application.ScreenUpdating = True '启用屏幕更新
  myBook.Close 'Excel工作薄关闭
  Set myBook = Nothing  '指定为Nothing，释放内存
  
  MsgBox "已转换完成！"
End Sub

实现效果

---

作者语

本着白嫖多年、回馈社会的态度，写下这篇文章，希望对你有所帮助，有不到位之处请多多包涵。