|
楼主 |
发表于 2012-11-2 17:43
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
这是宏代码:
Sub 邮件合并自动分记录保存到同目录的output文件夹()
'
' 主控文件有多页,合并的记录条数(数据源为标准的EXCEL数据,结构简单)分别生成文件;
' 以合并的关键域名如“序号+名称+自定义***”的形式做为文件名
' 本代码以第一二个字段名命名新文件,保存目录为主文档目录,一次合并所有记录并保存
'
'主文档的类型为信函
'合并全部数据记录
'假设主文档已链接好数据源,可以进行正常的邮件合并
Dim fso, f1
Dim myMerge As MailMerge, i As Integer, myname As String
Application.ScreenUpdating = False
Set fso = CreateObject("scripting.filesystemobject")
Set myMerge = ActiveDocument.MailMerge
If (fso.folderexists(ActiveDocument.Path & "\output")) Then
'如果存在不管他
Else
Set f1 = fso.createfolder(ActiveDocument.Path & "\output")
End If
Set myMerge = ActiveDocument.MailMerge
With myMerge.DataSource
If .Parent.State = wdMainAndDataSource Then
.ActiveRecord = wdFirstRecord
For i = 1 To .RecordCount
.FirstRecord = i
.LastRecord = i
.Parent.Destination = wdSendToNewDocument
'取得数据源第1个和第2个字段(合并域)的当前数据字符串,用以命名文件
myname = .DataFields(1).Value & .DataFields(2).Value
myPath = ActiveDocument.Path
.ActiveRecord = wdNextRecord
.Parent.Execute '每次合并一个数据记录
With ActiveDocument
.Content.Characters.Last.Previous.Delete '删除分节符
.SaveAs myPath & "\output\" & myname & ".doc" '生成的各文档保存于主文档的同目录下
.Close '关闭生成的文档(已保存)
End With
Next
End If
End With
Application.ScreenUpdating = True
End Sub |
|