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中的朋友有帮助。

<pre name="code" class="vb">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(&quot;I1&quot;).Text '设置的输出word文件路径
    
    arrTableName(1) = &quot;Brief&quot; ' 首页简表
    arrTableName(2) = &quot;BS&quot; ' 资产
    arrTableName(3) = &quot;BSS&quot; ' 负债及所有者权益
    arrTableName(4) = &quot;IS&quot; ' 利润表
    arrTableName(5) = &quot;CF&quot; ' 现金流量表
    arrTableName(6) = &quot;CFF&quot; ' 现金流量表补充材料
    arrTableName(7) = &quot;Main&quot; ' 主要财务指标


    arrReplaceText(1) = &quot;#DIV/0!&quot;
    arrReplaceText(2) = &quot;#NUM!&quot;
    
    ' 需要在Tools - References... 找到Microsoft Word 14.0 Object Library并选中。否则会提示“书签不存在”
    Set mWord = CreateObject(&quot;Word.Application&quot;)
   
    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产生的无效字符，如&quot;#DIV/0!&quot;
        For j = LBound(arrReplaceText) To UBound(arrReplaceText)
            .Selection.Find.ClearFormatting
            With .Selection.Find
                .Text = arrReplaceText(j)
                .Replacement.Text = &quot;&quot;
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchWholeWord = True
            End With
            .Selection.Find.Execute Replace:=wdReplaceAll
        Next
        
    End With
    
ret:
    Set mWord = Nothing
        
End Sub</pre>
<br />