网上搜了一些方法介绍,其中一种是用邮件合并功能,没看明白。目前的应用场景,经常需要把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("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</pre>
<br />
以下过程的思路如下:由于每张表格的行列及表头内容都是一样的(财务报表嘛,标准格式),因而只需将完整的表格放在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("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</pre>
<br />