Solved: insert number after bm, increment through pages in a doc created by mail merge

[mancubus]

hi all.

knowing little about word vba, i want to improve my project.

i have a document which is regularly sent to 8 departments and 19 persons. (dept and recipient numbers may change. but since it's a list provided by someone else, no problem.)

the document has 8 places changing, other parts remaning identical.

so i recorded a mail merge macro and modified it.
for 7 places i have bookmarks and the procedure inserts texts defined as variables.

what i need is to be able to insert a Doc ID number to the pages of new document which is created by mail merge that starts at a changing number. (this number is also provided by the same person.) the red bit of the following text.

Doc ID : Dept_ID/2011/Class_ID/INSERT NUMBER HERE

the second part that i need is formatting the recipient lines.

this is what i get

TO : Ms./Mr. Recipient_1
Dept Head
Ms./Mr. Recipient_2
Div Head

this what i want to get:

TO : Ms./Mr. Recipient_1
.......Dept Head
.......Ms./Mr. Recipient_2
.......Div Head


attached are mail merge doc and recipient list xl files

[mancubus]

this is the macro i have so far...
using office 2010


Sub mail_merge()

Dim pathStr As String, sourceStr As String, fileStr As String
Dim subj_dtStr As String, open_dtStr As String, rpt_periodStr As String

pathStr = "H:\office_files\mm_doc\"
sourceStr = "recipient_list.xlsx"
fileStr = "letter_doc.docx"
subj_dtStr = "31/08/2011"
open_dtStr = "22/09/2011"
rpt_periodStr = "01/07/2011-31/08/2011"

ActiveDocument.Bookmarks("subj_dt").Range.InsertAfter subj_dtStr
ActiveDocument.Bookmarks("subj_dt2").Range.InsertAfter subj_dtStr
ActiveDocument.Bookmarks("subj_dt3").Range.InsertAfter subj_dtStr
ActiveDocument.Bookmarks("open_dt").Range.InsertAfter open_dtStr
ActiveDocument.Bookmarks("rpt_period").Range.InsertAfter rpt_periodStr
ActiveDocument.Bookmarks("doc_dt").Range.InsertAfter Date

ActiveDocument.MailMerge.OpenDataSource Name:=pathStr & sourceStr _
, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & pathStr & sourceStr & _
";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System d" _
, SQLStatement:="SELECT * FROM `mail_merge$`", SQLStatement1:="", SubType _
:=wdMergeSubTypeAccess

Selection.GoTo What:=wdGoToBookmark, Name:="recip"
ActiveDocument.Fields.Add Range:=Selection.Range, Type:=wdFieldMergeField, Text:="""Recipient"""

With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With

ActiveDocument.SaveAs2 pathStr & fileStr, FileFormat:=wdFormatXMLDocument, CompatibilityMode:=14

'CODES FOR INSERTING INCREMENTING NUMBERS HERE

End Sub

[mancubus]

'CODES FOR INSERTING INCREMENTING NUMBERS HERE


ok then.
after a number of tries, googling and macro recording, i finally get it.
"sometimes" macro skips numbering the first page.


'inserts incrementing custom number after each search string
Selection.HomeKey wdStory
ActiveDocument.Repaginate
sFindText = "Doc ID : Dept_ID/2011/Class_ID/"
iPage = ActiveDocument.BuiltInDocumentProperties("Number of Pages")
numStr = InputBox("Pls Enter Starting Num!", "Doc No")
i = numStr
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = sFindText
.Forward = True
.Wrap = wdFindContinue
End With
Do
With Selection.Find
If .Found = True Then
.Replacement.Text = sFindText & i
.Execute Replace:=wdReplaceOne
End If
.Execute
End With
i = i + 1
If (i = numStr + iPage) Then Exit Do
Loop
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
End With

'inserts 4 tabs to consecutive three lines after each search string
sFindText = "TO"
i = 1
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = sFindText
.MatchCase = True
.MatchWholeWord = True
.Forward = True
.Wrap = wdFindContinue
.Execute
End With
Do
With Selection
If .Find.Found = True Then
.MoveDown Unit:=wdLine, Count:=1
.HomeKey Unit:=wdLine
.TypeText Text:=vbTab & vbTab & vbTab & vbTab
.MoveDown Unit:=wdLine, Count:=1
.HomeKey Unit:=wdLine
.TypeText Text:=vbTab & vbTab & vbTab & vbTab
.MoveDown Unit:=wdLine, Count:=1
.HomeKey Unit:=wdLine
.TypeText Text:=vbTab & vbTab & vbTab & vbTab
End If
.Find.Execute
End With
i = i + 1
If (i = numStr + iPage + 1) Then Exit Do
Loop
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
End With

[macropod]

Hi mancubus,

Why are you even bothering with vba? Why not simply set up your mailmerge main document with the required mergefields at the required locations?

[mancubus]

Hi Paul.

thaks for the reply.

it's a part of a procedure. actually, 2 steps before the final step...

after this, the doc will be splitted into separate docs page by page.
and finally mailed to recipients with other attachments (excel, pp, etc files).

[macropod]

Hi mancubus,

Even as part of a larger procedure, it generally doesn't make a lot of sense to create the document from scratch every time, when you could simply open an existing document that's already been configured for the purpose. Furthermore, such a document is inherently easier to maintain (especially for 'ordinary' users) than a mass of code.

[mancubus]

thanks Paul.

will try both ways...