How do I split my one document into many at page breaks in VBA? - vba

Question

I am new to VBA. I got this macro from online and it has worked for me before, but now I am getting a runtime error from it.
The macro is supposed to take a mail merged document I have, and split it into individual documents for each recipient.
The runtime error 5487 is pointing me to the line
" .SaveAs fileName:=StrTxt &...".
I have tried to save it as a different file format, and have gone through the other posts on StackOverflow where others have the same error, but I am still getting the error message.
My code is:
Sub SplitMergedDocument()
' Source: http://msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Const StrNoChr As String = """*./\:?|"
Dim i As Long, j As Long, k As Long, StrTxt As String
Dim Rng As Range, Doc As Document, HdFt As HeaderFooter
Application.ScreenUpdating = False
j = InputBox("How many Section breaks are there per record?", "Split By Sections ", 1)
With ActiveDocument
For i = 1 To .Sections.Count - 1 Step j ' Process each Section
With .Sections(i)
Set Rng = .Range.Paragraphs(1).Range ' Get 1st paragraph
With Rng
.MoveEnd wdCharacter, -1 'range to exclude final paragraph break
StrTxt = .Text
For k = 1 To Len(StrNoChr)
StrTxt = Replace(StrTxt, Mid(StrNoChr, k, 1), "_")
Next
End With
' Construct destination file path & name
StrTxt = ActiveDocument.Path & Application.PathSeparator & StrTxt
Set Rng = .Range ' Get whole Section
With Rng
If j > 1 Then .MoveEnd wdSection, j - 1
.MoveEnd wdCharacter, -1 'Contract range to exclude Section break
.Copy ' Copy range
End With
End With
' Create output document
Set Doc = Documents.Add(Template:=ActiveDocument.AttachedTemplate.FullName _
, Visible:=False)
With Doc
' Paste contents into output document, preserving formatting
.Range.PasteAndFormat (wdFormatOriginalFormatting)
' Delete trailing paragraph breaks & page breaks at end
While .Characters.Last.Previous = vbCr Or .Characters.Last.Previous = Chr(12)
.Characters.Last.Previous = vbNullString
Wend
For Each HdFt In Rng.Sections(j).Headers ' Replicate headers & footers
.Sections(j).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
For Each HdFt In Rng.Sections(j).Footers
.Sections(j).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
Next
' Save & close output document
.SaveAs FileName:=StrTxt & ".docx", FileFormat:=wdFormatXMLDocument _
, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next
End With
Set Rng = Nothing: Set Doc = Nothing
Application.ScreenUpdating = True
End Sub
Thank you!

Answer 1

Without knowing more (such as the value of StrTxt), I can't say for sure why you're getting the error but it's likely either an invalid filename, or the file is locked by another process, or a permissions issue.
Perhaps the procedure below will work better for you. (I'm unclear on the significance of "records" in your code.)
Split document into separate files for each page:
This procedure splits the ActiveDocument into one .DOCX file per "visible page" (calculated page breaks, manual page breaks, section breaks, etc).\
Sub WordDocToPages()
'splits active Word doc by page into separate DOCX files (same folder as active doc)
Dim doc As Document, docPage As Document, rgPage As Range
Dim pgNum As Long, pgCnt As Long, ext As String, fName As String
Set doc = ActiveDocument 'Use current document
Set rgPage = doc.Range 'create range of 1 page
Application.ScreenUpdating = False 'prevent screen updates
pgCnt = doc.Content.Information(wdNumberOfPagesInDocument) 'get page count
Do While pgNum < pgCnt
pgNum = pgNum + 1 'increment page counter
Application.StatusBar = "Saving page " & pgNum & " of " & pgCnt
If pgNum < pgCnt Then
Selection.GoTo wdGoToPage, wdGoToAbsolute, pgNum + 1 'top of next page
rgPage.End = Selection.Start 'end of page=top of next
Else
rgPage.End = doc.Range.End 'end of last page=EOF
End If
rgPage.Copy 'copy page
Set docPage = Documents.Add(Visible:=False) 'create new document
With docPage
With .Range
.Paste 'paste page
.Find.Execute Findtext:="^m", ReplaceWith:="" 'remove manual breaks
.Select
End With
With Selection
.EndKey wdStory 'goto end of doc
.MoveLeft wdCharacter, 1, wdExtend 'remove final CR
If Asc(.Text) = 13 Then .Delete wdCharacter, 1 'remove trailing CR
End With
ext = Mid(doc.FullName, InStrRev(doc.FullName, ".")) 'extract file extension
fName = Replace(doc.FullName, ext, " #" & _
Format(pgNum, String(Len(CStr(pgCnt)), "0")) & ".docx") 'new filename
.SaveAs fName, wdFormatDocumentDefault 'save single-page doc
.Close 'close new document
End With
rgPage.Collapse wdCollapseEnd 'ready for next page
Loop
Application.ScreenUpdating = True 'resume screen updates
Application.StatusBar = "Document was split into " & pgNum & " files."
Set docPage = Nothing: Set rgPage = Nothing: Set doc = Nothing 'cleanup objects
End Sub
This is loosely based on the example at Usefulware Sharing.
The new files are saved to the same folder as ActiveDocument.Path, with the document title appended with a sequential number. Note that existing output files are overwritten, and there is no validation or error handling.