excel表格输出到word中的一种方法

网上搜了一些方法介绍，其中一种是用邮件合并功能，没看明白。目前的应用场景，经常需要把excel里头的几张财务报表，作为附表拷贝到word报告中，每次复制粘贴后，格式都变了，用“仅保留文本”的粘贴方式也不奏效，文字大小、数字对齐都不合要求，需要手动调一遍，费时且易出错，很痛苦。

以下过程的思路如下：由于每张表格的行列及表头内容都是一样的（财务报表嘛，标准格式），因而只需将完整的表格放在word文档中作为模板，然后拷贝数值部分的行列填充到word中的对应表格中即可。

实施要点：
1、在excel中用名称管理器定义数值区域，不要写死区域（如B3:E80），避免未来修改
2、在word表格中，定义书签以便快速定位，但标签要放在表头单元格中，如果放在数据单元格中，excel数据覆盖过来后就会丢失该书签
3、在excel中，要勾选对word的object library的引用（见代码注释），否则无法正常执行
4、在excel工作表里，放置一个按钮，关联到btn3_click()过程

操作非常简单：点击按钮，一键搞定。原来要几个小时，弄完后眼花头痛非常累，现在只需几秒钟，瞬间搞定！最重要的是，准确率100%，而原来再细心的人也难保在N次拷贝粘贴中不出错一次。

代码一个小问题留待读者扩展：点击按钮后，偶尔会报错抛异常，提示剪贴板为空，这时需要手动关闭word文件，重新再执行一次。所以代码中应该再加个异常捕获，抛异常后，自动关闭word文档，并提示用户重新执行一遍，就比较理想了。

希望对经常需要从excel中拷贝粘贴财务报表到word中的朋友有帮助。

Sub btn3_click() 
  
     'On Error GoTo ret ' 错误处理（关闭文件句柄，避免内存泄露） 
  
     'Dim mWord As New Word.Application 
  
     'Dim mDoc As Document 
  
     Set srcSheet = ActiveSheet 
  
     Dim i, j, ret, dstFileName, arrTableName(1 To 7), arrReplaceText(1 To 2) 
  
      
  
     dstFileName = srcSheet.Range("I1").Text '设置的输出word文件路径 
  
      
  
     arrTableName(1) = "Brief" ' 首页简表 
  
     arrTableName(2) = "BS" ' 资产 
  
     arrTableName(3) = "BSS" ' 负债及所有者权益 
  
     arrTableName(4) = "IS" ' 利润表 
  
     arrTableName(5) = "CF" ' 现金流量表 
  
     arrTableName(6) = "CFF" ' 现金流量表补充材料 
  
     arrTableName(7) = "Main" ' 主要财务指标 
  
 
  
 
  
     arrReplaceText(1) = "#DIV/0!" 
  
     arrReplaceText(2) = "#NUM!" 
  
      
  
     ' 需要在Tools - References... 找到Microsoft Word 14.0 Object Library并选中。否则会提示“书签不存在” 
  
     Set mWord = CreateObject("Word.Application") 
  
     
  
     With mWord 
  
         .Visible = True ' word窗口可见 
  
         '.Activate 
  
         .Documents.Open Filename:=dstFileName 
  
          
  
         For i = LBound(arrTableName) To UBound(arrTableName) 
  
             'Application.Goto Reference:=arrTableName(i) 
  
             'Selection.Copy 
  
             srcSheet.Range(srcSheet.Names(arrTableName(i))).Copy 
  
              
  
             .Selection.Goto What:=wdGoToBookmark, Name:=arrTableName(i) 
  
             .Selection.MoveDown Unit:=wdLine, Count:=1 
  
             .Selection.Paste 
  
         Next 
  
          
  
         ' 最后清空excel产生的无效字符，如"#DIV/0!" 
  
         For j = LBound(arrReplaceText) To UBound(arrReplaceText) 
  
             .Selection.Find.ClearFormatting 
  
             With .Selection.Find 
  
                 .Text = arrReplaceText(j) 
  
                 .Replacement.Text = "" 
  
                 .Forward = True 
  
                 .Wrap = wdFindContinue 
  
                 .Format = False 
  
                 .MatchWholeWord = True 
  
             End With 
  
             .Selection.Find.Execute Replace:=wdReplaceAll 
  
         Next 
  
          
  
     End With 
  
      
  
 ret: 
  
     Set mWord = Nothing 
  
          
  
 End Sub