VBA TO UNMERGE WORD DOCUMENT/SAVE WITH UNIQUE FILE NAME/DEFINE LOCATION

[stevembe]

I may be asking a bit much here but I have a merged word document that contains a letter to employees that are all 3 pages long. I need to save these letters as seperate documents so I am wondering if there is some VBA code that takes the following steps:

Unmerge individual letters
Saves the letter with a unique name into a folder with a defined path

Any help would be greatly appreciated, there are over 200 letters :(

[macropod]

See 'Split the single merged document into separate letters' at: http://www.gmayor.com/individual_merge_letters.htm. Note that the link also shows how you can generate the merges to individual letters, without the need to split the output afterwards.

[mrojas]

If I'm understanding correctly, you want to save each page of a three-page letter to individual documents such that each three-page letter ends up generating three new one-page document, or a total of at least 600 documents?

What would the source of the unique name for each new document be? Would the user be prompted for each name? How about the path?

[macropod]

If I'm understanding correctly, you want to save each page of a three-page letter to individual documents such that each three-page letter ends up generating three new one-page document, or a total of at least 600 documents?
The OP refers to saving individual three-page letters, not to saving each page individually...

[stevembe]

Basically I have the following code which saves each individual 3 page letter to this path: H:\Terms & Conditions\Test Unmerge.


Sub BreakOnSection()
Application.Browser.Target = wdBrowseSection
For i = 1 To ((ActiveDocument.Sections.Count) - 1)
ActiveDocument.Bookmarks("\Section").Range.Copy
Documents.Add
Selection.Paste
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
ChangeFileOpenDirectory "H:\Terms & Conditions\Test Unmerge"
DocNum = DocNum + 1
ActiveDocument.SaveAs FileName:="Terms & Conditions" & ActiveDocument.Bookmarks("Name_save") & “ “ & ActiveDocument.Bookmarks("Name_save") ".doc".
ActiveDocument.Close
Application.Browser.Next
Next i
ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub


The problem is this just saves each individual letter as Terms & Conditions1, 2, 3, 4. What I want it do is save the letter by the employee name in the letter which is a mail merge field. Any help much appreciated

[macropod]

Having completed the merge, there are no mergefields or bookmarks from which it would be possible to retrieve the data you want for the filenames. Accordingly, you're going to have to code into you macro the logic for finding where in each Section the relevant data should be retrieved (e.g. paragraph 2, words 1 & 2).

[stevembe]

Thanks but I have got a little bit further. Can anyone help with a slight adjustment to this code. It is currently set to unmerge a mail merge separating letters into single documents, saving them to a directory path and naming them “Terms & Conditions” followed by the reading the surname and first name which is currently the 1st line of the letter. The letter has changed in that the name is now the 4th line of the letter. Can anyone help me adjust the code so it reads the 4th line and not the 1st? Thank you in advance


Sub BreakOnSection()
Application.Browser.Target = wdBrowseSection
For i = 1 To ((ActiveDocument.Sections.Count) - 1)
ActiveDocument.Bookmarks("\Section").Range.Copy
Documents.Add
Selection.Paste
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1

txtName = ActiveDocument.Range(Start:=0, End:=ActiveDocument.Sentences(1).End - 1).Text
For j = Len(txtName) To 1 Step -1
If Left(Right(txtName, j), 1) = " " Then
Exit For
End If
Next

ChangeFileOpenDirectory "H:\Terms & Conditions\Test Unmerge"
'DocNum = DocNum + 1
'ActiveDocument.SaveAs FileName:="Terms & Conditions_" & DocNum & ".doc"
ActiveDocument.SaveAs FileName:="Terms & Conditions_" & Right(txtName, j - 1) & "_" & Left(txtName, Len(txtName) - j) & ".doc"
ActiveDocument.Close
Application.Browser.Next
Next i
'ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub

[macropod]

The letter has changed in that the name is now the 4th line of the letter. Can anyone help me adjust the code so it reads the 4th line and not the 1st?
How one might do that depends on what you mean by "the 4th line". Are these lines defined by paragraph breaks, or manual line breaks? With Word's formatting display (which you can toggle on/off via the ¶ symbol on the Home tab), turned 'on',paragraph breaks look like ¶ and manual line breaks look like ↵.

PS: There is no need to 'Select' anything for this.

[stevembe]

How one might do that depends on what you mean by "the 4th line". Are these lines defined by paragraph breaks, or manual line breaks? With Word's formatting display (which you can toggle on/off via the ¶ symbol on the Home tab), turned 'on',paragraph breaks look like ¶ and manual line breaks look like ↵.

PS: There is no need to 'Select' anything for this.

The first line has Date
The second line has Reference
The third line is blank
The fourth line is name which is what I want it to read

[macropod]

If you can't be bothered to answer a question you've been asked that is critical to any solution, don't expect one.

[stevembe]

If you can't be bothered to answer a question you've been asked that is critical to any solution, don't expect one.

Why the animosity and abrupt response? I apologise for not perhaps being as educated on VBA as yourself but perhaps I did not understand the question. I thought by what I said it was obvious there are paragraph breaks but obviously not. Maybe a little more patience and understanding would not go amiss.

[macropod]

The requested information has nothing to do with your knowledge or otherwise of vba. I did not ask for a 'pictorial' representation of your lines; I asked for what separated them. That was a very specific question and you chose not to answer it. How do you suppose anyone seeing your post would know whether the lines are separated by line breaks or paragraph breaks? Can you see either of the symbols I referred to in your post?

Now that you seem to understand the difference between answering the questions you're asked instead of posting content that doesn't, try:

Sub Demo()
Application.ScreenUpdating = False
Dim Sctn As Section, StrTxt As String, Rng As Range, Doc As Document
With ActiveDocument
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
For Each Sctn In .Sections
StrTxt = .FullName
With Sctn
Set Rng = .Range.Paragraphs(4).Range
With Rng
.MoveEnd wdCharacter, -1
StrTxt = Left(StrTxt, InStrRev(StrTxt, ".") - 1) & "_" & _
.Text & Right(StrTxt, Len(StrTxt) - InStrRev(StrTxt, ".") + 1)
End With
Set Rng = .Range
With Rng
.MoveEnd wdCharacter, -1
.Copy
End With
End With
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
With Doc
.Range.Paste
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
.SaveAs FileName:=StrTxt, AddToRecentFiles:=False
.Close SaveChanges:=True
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub

[stevembe]

The requested information has nothing to do with your knowledge or otherwise of vba. I did not ask for a 'pictorial' representation of your lines; I asked for what separated them. That was a very specific question and you chose not to answer it. How do you suppose anyone seeing your post would know whether the lines are separated by line breaks or paragraph breaks? Can you see either of the symbols I referred to in your post?

Now that you seem to understand the difference between answering the questions you're asked instead of posting content that doesn't, try:

Sub Demo()
Application.ScreenUpdating = False
Dim Sctn As Section, StrTxt As String, Rng As Range, Doc As Document
With ActiveDocument
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
For Each Sctn In .Sections
StrTxt = .FullName
With Sctn
Set Rng = .Range.Paragraphs(4).Range
With Rng
.MoveEnd wdCharacter, -1
StrTxt = Left(StrTxt, InStrRev(StrTxt, ".") - 1) & "_" & _
.Text & Right(StrTxt, Len(StrTxt) - InStrRev(StrTxt, ".") + 1)
End With
Set Rng = .Range
With Rng
.MoveEnd wdCharacter, -1
.Copy
End With
End With
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
With Doc
.Range.Paste
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
.SaveAs FileName:=StrTxt, AddToRecentFiles:=False
.Close SaveChanges:=True
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub

I appreciate your help and sorry for any misunderstanding. I do admit to not fully understanding the code you sent, it is totally different and I can not see anywhere that there is a filepath to where the documents will be saved. In addition I have also just been given the mail merged document, it is over 2000 letters and the header looks like this:

Date : 2nd December 2013
Ref : NEP/1/2013





Mr B Smith
00001001
M/GH

I need to capture the name and number underneath in the file name. I hope this is possible

[stevembe]

The breaks are ¶ sorry

[macropod]

As coded, the macro automatically saves the individual files to the same folder as the source document has been saved in (so you'll need to make sure it's been saved as 'Terms & Conditions'). If that's unsuitable, post back.

Assuming your name & number are indeed the 4th & 5th paragraphs in your document (the extensive spaces before the name in your last post suggest it may be otherwise), try changing the first 'With Rng ... End With' block to:


With Rng
.MoveEnd wdParagraph, 1
.MoveEnd wdCharacter, -1
StrTxt = Left(StrTxt, InStrRev(StrTxt, ".") - 1) & "_" & _
Replace(.Text, vbCr, "_") & Right(StrTxt, Len(StrTxt) - InStrRev(StrTxt, ".") + 1)
End With

[stevembe]

I am sorry, I am losing track and my VBA is not up to much. I really need a different path specified and also now I am unsure where to add the additional code you sent. Is it possible you could combine it all so it saves as Terms & Conditions, name then number in a specified path.

Apologies for being awkward, please be patient, I do appreciate your help, I have found there are over 2000 letters.

[macropod]

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim Sctn As Section, StrTxt As String, Rng As Range, Doc As Document
With ActiveDocument
'Delete trailing paragraph & Section breaks at the end
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
'Process each Section
For Each Sctn In .Sections
'Pre-populate the destination filename
StrTxt = "H:\Terms & Conditions\Test Unmerge\Terms & Conditions_"
With Sctn
'Get the 4th paragraph
Set Rng = .Range.Paragraphs(4).Range
With Rng
'Extend the range to include the next paragraph
.MoveEnd wdParagraph, 1
'Contract the range to exclude the final paragraph break
.MoveEnd wdCharacter, -1
'Add the range contents & extension to the pre-populated the destination filename
StrTxt = StrTxt & Replace(.Text, vbCr, "_") & ".doc"
End With
'Get the whole Section
Set Rng = .Range
With Rng
'Contract the range to exclude the Section break
.MoveEnd wdCharacter, -1
'Copy the range
.Copy
End With
End With
'Create the output document
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
With Doc
'Paste contents into the output document
.Range.Paste
'Delete trailing paragraph breaks at the end
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
'Save & close the output document
.SaveAs FileName:=StrTxt, AddToRecentFiles:=False
.Close SaveChanges:=True
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub

[stevembe]

Perfect macropod, thank you so much

[stevembe]

The code is running so I assumed everything was ok, however, the code runs but all that happens is it copies the last letter to the clipboard and not saving all the individual letters to the path I want them all to go to.

[macropod]

All the files are saved to the folder 'H:\Terms & Conditions\Test Unmerge\', prefixed with 'Terms & Conditions_'
I suspect the reason you're not getting the expected results is as I suggested in post #15 (http://www.vbaexpress.com/forum/showthread.php?48228-VBA-TO-UNMERGE-WORD-DOCUMENT-SAVE-WITH-UNIQUE-FILE-NAME-DEFINE-LOCATION&p=300666&viewfull=1#post300666) (i.e. your employee name is not in the 4th paragraph). If it isn't and it's in, say, the 6th paragraph, all that will happen is that Word will repeatedly save a file named 'Terms & Conditions_.doc', because the real 4th & 5th paragraphs it's looking at are empty. So you need to change the 4 in Paragraphs(4) to whatever paragraph # actually contains the employee name. This goes right back to the question I asked in post #8 (http://www.vbaexpress.com/forum/showthread.php?48228-VBA-TO-UNMERGE-WORD-DOCUMENT-SAVE-WITH-UNIQUE-FILE-NAME-DEFINE-LOCATION&p=300646&viewfull=1#post300646) - about what separates the 'lines'.

[stevembe]

All the files are saved to the folder 'H:\Terms & Conditions\Test Unmerge\', prefixed with 'Terms & Conditions_'
I suspect the reason you're not getting the expected results is as I suggested in post #15 (http://www.vbaexpress.com/forum/showthread.php?48228-VBA-TO-UNMERGE-WORD-DOCUMENT-SAVE-WITH-UNIQUE-FILE-NAME-DEFINE-LOCATION&p=300666&viewfull=1#post300666) (i.e. your employee name is not in the 4th paragraph). If it isn't and it's in, say, the 6th paragraph, all that will happen is that Word will repeatedly save a file named 'Terms & Conditions_.doc', because the real 4th & 5th paragraphs it's looking at are empty. So you need to change the 4 in Paragraphs(4) to whatever paragraph # actually contains the employee name. This goes right back to the question I asked in post #8 (http://www.vbaexpress.com/forum/showthread.php?48228-VBA-TO-UNMERGE-WORD-DOCUMENT-SAVE-WITH-UNIQUE-FILE-NAME-DEFINE-LOCATION&p=300646&viewfull=1#post300646) - about what separates the 'lines'.

Thank you, that worked but with a problem, sorry, the name has moved to para 13 but I also wanted to add the number at the end of the filename which is para 14 so it saved as:

Name 00001234 (example)

Can the code be adapted so it just reads name then number, there is no longer a need for the prefix of terms & conditions.

The only other issue is that when I try to open any of the extracted documents it will not let me and comes up with the error message The file can not be opened because there are problems with the contents.

Thanks for the attention and any help would be appreciated.

[macropod]

I've already told you how to change the paragraph reference from 4 to 13 and I'd have thought it perfectly obvious where in the code the filename prefix appears. Surely you can make those changes without me having to spell them out!?

The error message suggests the file extension (which I got from your code) does not match the file format that you're working with. You may need to change:
StrTxt = StrTxt & Replace(.Text, vbCr, "_") & ".doc"
to:
StrTxt = StrTxt & Replace(.Text, vbCr, "_") & ".docx"

[stevembe]

I've already told you how to change the paragraph reference from 4 to 13 and I'd have thought it perfectly obvious where in the code the filename prefix appears. Surely you can make those changes without me having to spell them out!?

The error message suggests the file extension (which I got from your code) does not match the file format that you're working with. You may need to change:
StrTxt = StrTxt & Replace(.Text, vbCr, "_") & ".doc"
to:
StrTxt = StrTxt & Replace(.Text, vbCr, "_") & ".docx"

Yes I did figure that out, thank you but I also asked to include paragraph 14 in addition to 13 and to only have this as the filename i.e. nothing to prefix this.

[macropod]

but I also asked to include paragraph 14 in addition to 13 and to only have this as the filename i.e. nothing to prefix this.
I HAVE ALREADY TOLD YOU HOW TO DO ALL OF THOSE THINGS!! IF YOU RAN THE MACRO WITH THE SUGGESTED CHANGES, YOU WOULD GET THE RESULTS YOU REQUIRE.

[stevembe]

I HAVE ALREADY TOLD YOU HOW TO DO ALL OF THOSE THINGS!! IF YOU RAN THE MACRO WITH THE SUGGESTED CHANGES, YOU WOULD GET THE RESULTS YOU REQUIRE.

I see where you have told me how to change to para 13 which I get but I can not see where you told me how to also add para 14 in additions to 13. I want to capture both paras in the file name save.

[stevembe]

Ok, I figured it out but it continues to remove the 0pt spacing between paragraphs and the outcome is 1.5 which is strange. Also there is a logo as the header but that is removed when extracted.

[macropod]

it continues to remove the 0pt spacing between paragraphs and the outcome is 1.5 which is strange. Also there is a logo as the header but that is removed when extracted.
This is your first mention of any spacing issues or of the presence of a header. The spacing issues would not occur if your mailmerge main document had honoured the Style definitions in its template. Nevertheless, both issues can be handled with a slightly different approach:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrTxt As String, Rng As Range, Doc As Document, HdFt As HeaderFooter
With ActiveDocument
'Process each Section
For i = 1 To .Sections.Count - 1
With .Sections(i)
'Get the 13th paragraph
Set Rng = .Range.Paragraphs(13).Range
With Rng
'Extend the range to include the 14th paragraph
.MoveEnd wdParagraph, 1
'Contract the range to exclude the final paragraph break
.MoveEnd wdCharacter, -1
'Construct the destination file path & name
StrTxt = "H:\Terms & Conditions\Test Unmerge\" & Replace(.Text, vbCr, "_") & ".docx"
End With
'Get the whole Section
Set Rng = .Range
With Rng
'Contract the range to exclude the Section break
.MoveEnd wdCharacter, -1
'Copy the range
.Copy
End With
End With
'Create the output document
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName, Visible:=False)
With Doc
'Paste contents into the output document, preserving the formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
'Delete trailing paragraph breaks & page breaks at the end
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
'Replicate the headers & footers
For Each HdFt In Rng.Sections(1).Headers
HdFt.Range.Copy
.Sections(1).Headers(HdFt.Index).Range.PasteAndFormat (wdFormatOriginalFormatting)
Next
For Each HdFt In Rng.Sections(1).Footers
HdFt.Range.Copy
.Sections(1).Footers(HdFt.Index).Range.PasteAndFormat (wdFormatOriginalFormatting)
Next
'Save & close the output document
.SaveAs FileName:=StrTxt, AddToRecentFiles:=False
.Close SaveChanges:=True
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub
Note the use of '.PasteAndFormat (wdFormatOriginalFormatting)' instead of just '.Paste' and the additional code to replicate the headers & footers.

[stevembe]

Thank you for that, all running well now after several test runs. Sorry about the struggle and for any misunderstanding, the time you have taken to assist is very much appreciated.

[stevembe]

Just one final question (I promise). How would I adjust the code so that it saves as para 14 first and then para 13 so number first then name?

[macropod]

Change:

'Get the 13th paragraph
Set Rng = .Range.Paragraphs(13).Range
With Rng
'Extend the range to include the 14th paragraph
.MoveEnd wdParagraph, 1
'Contract the range to exclude the final paragraph break
.MoveEnd wdCharacter, -1
'Construct the destination file path & name
StrTxt = "H:\Terms & Conditions\Test Unmerge\" & Replace(.Text, vbCr, "_") & ".docx"
End With
to:

'Get the 14th paragraph
Set Rng = .Range.Paragraphs(14).Range
With Rng
.MoveEnd wdCharacter, -1
'Construct the destination file path & first part of name
StrTxt = "H:\Terms & Conditions\Test Unmerge\" & .Text & "_"
End With
'Get the 13th paragraph
Set Rng = .Range.Paragraphs(13).Range
With Rng
.MoveEnd wdCharacter, -1
'Construct balance of file name
StrTxt = StrTxt & .Text & ".docx"
End With