前提:先製作完成Word和資料來源的關聯
Sub ProduceDoc()
'Dim stMedd As String'Dim obMapp As Variant
'stMedd = "請選擇分割後申請表目錄:" '選擇目錄
'Set obMapp = CreateObject("Shell.Application").BrowseForFolder(0, stMedd, &H1)
'If Not obMapp Is Nothing Then
' linkstr = obMapp.self.Path + "\"
'Else
' Exit Sub
'End If
Dim fso As Object
Dim strSrcName As String, strNewName As String
Set fso = CreateObject("Scripting.FileSystemObject")
strSrcName = ActiveDocument.FullName
'MsgBox fso.GetParentFolderName(strSrcName)
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord
For i = 1 To ActiveDocument.MailMerge.DataSource.RecordCount
strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
fso.GetBaseName(strSrcName) & "_" & i & "." & fso.GetExtensionName(strSrcName))
DoWork (strNewName)
Next i
MsgBox "匯出" + CStr((ActiveDocument.MailMerge.DataSource.RecordCount)) + " 筆資料,結束!"
End Sub
Sub DoWork(filePath As String)
Dim DokName As String
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
.LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
DokName = .DataFields("FieldName").Value 'Change "FieldName" to your MailMerge field name
End With
' Merge the active record
.Execute Pause:=False
End With
ActiveDocument.Range(0, 0).Select
Selection.PageSetup.SectionStart = wdSectionContinuous
Selection.WholeStory
Selection.Fields.Update '更新照片欄位資料
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With ActiveDocument.Content.Find 'Selection.Find.Text = "<br />" ‘取代<br />為斷行
.Replacement.Text = "^p"
.Forward = True
. Wrap = wdFindContinue ‘不跳出取代後結果
'.Wrap = wdFindAsk have message show
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.CorrectHangulEndings = False
.HanjaPhoneticHangul = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
.Execute Replace:=wdReplaceAll
End With
With ActiveDocument.Content.Find 'Selection.Find
.Text = "^b" ’取代節號為空白
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
.Execute Replace:=wdReplaceAll
End With
‘頁尾資料
Selection.Sections(1).Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Text = DokNameSelection.Sections(1).Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
' Save the resulting document.
ActiveDocument.SaveAs2 FileName:=filePath, FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False, CompatibilityMode:=14
' Close the resulting document
ActiveWindow.Close
' Now, back in the template document, advance to next record
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
End Sub