网上搜了一些方法介绍，其中一种是用邮件合并功能，没看明白。目前的应用场景，经常需要把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 />