VBA实例01：复制多个Excel表到Word

excelperfect

实例场景

有些时候，需要将多个Excel表复制到Word文档中指定的位置。一般可以使用通常的复制/粘贴操作，然而如果表很多的话，VBA就派上用场了。

演示数据

我们准备了3个表，如下图1至图3所示。

图1

图2

图3

准备工作

我们需要将这3个表插入到名为“Excel报表.docx”的Word文档中。因为要分别插入到文档中指定位置，所以我们在要插入的位置定义书签。将光标放置到要插入表的位置，单击功能区“插入”选项卡“链接”组中的“书签”，输入书签名，单击“添加”按钮，如下图4所示。

图4

由于要插入3个表，因此在要插入的位置添加3个书签。在本例中，我们将3个书签分别命名为“书签1”、“书签2”和“书签3”。

在VBA编辑器中，单击“工具——引用”，找到并选取“Microsoft Word 16.0 Object Library”前的复选框，如下图5所示。

图5

代码

在VBA编辑器中，插入一个新模块，输入下面的代码：

'强制数组下标以1开始Option Base 1
'将Excel表复制到一个新的Word文档Sub ExcelTablesToWord() Dim rngTable As Excel.Range Dim WordApp As Word.Application Dim myDoc As Word.Document Dim WordTable As Word.Table Dim varTableArray As Variant Dim varBookmarkArray As Variant Dim i As Integer '要复制的Excel表的表名 varTableArray = Array('表1', '表2', '表3') '要粘贴到Word文档的书签名 varBookmarkArray = Array('书签1', '书签2', '书签3') '关闭屏幕更新和事件 Application.ScreenUpdating = False Application.EnableEvents = False '将变量赋值给目标Word文档 On Error GoTo NotFoundWordDoc Set WordApp = GetObject(Class:='Word.Application') WordApp.Visible = True Set myDoc = WordApp.Documents('Excel报表.docx') On Error GoTo 0 '遍历并粘贴Excel表 For i = LBound(varTableArray) To UBound(varTableArray) '从Excel中复制表区域 Set rngTable = ThisWorkbook.Worksheets(i).ListObjects(varTableArray(i)).Range rngTable.Copy '将表粘贴到Word myDoc.Bookmarks(varBookmarkArray(i)).Range.PasteExcelTable _ LinkedToExcel:=False, _ WordFormatting:=False, _ RTF:=False '自动调整表以适应Word文档 Set WordTable = myDoc.Tables(i) WordTable.AutoFitBehavior (wdAutoFitWindow) Next i '给出消息 MsgBox '复制完成!', vbInformation GoTo EndRoutine '错误处理NotFoundWordDoc: MsgBox 'Word文件'Excel报表.docx'未打开,重试.', 16 EndRoutine: Application.ScreenUpdating = True Application.EnableEvents = True Application.CutCopyMode = FalseEnd Sub

运行代码，结果如下图6所示。

图6

应用小结

1.在Word中使用书签功能进行定位，并在代码中利用书签，是一种常用的技巧。

2.使用数组并将表名与书签名相对应，能够极大地方便代码的编写。

3.对Excel数据和Word文档进行合适的设置，能够很好地帮助数据处理。