Accepted code still wrong "MS Access Using VBA Split Word Docx file into separate Doc for Each Page"

Can you provide a sample of a Word document that you are having the problem with please.

---

»bp

Here are both the original merge file and the first of the resulting split files.
Test_0001.docx
April-31.docx

I was expecting to see some "^" characters in the input document, did I misunderstand the VBA, it seemed to look for those, and use the enclosed text as a file name for the output file?

---

»bp

I deleted the lines of code that found the file name and simply set strNewName to "Test." I want to get the "splitting: working properly first.

Okay, then could you share the current code you are using that is having the problem please.

---

»bp

Public Sub ParseDoc(ByVal filename As String)
On Error GoTo ErrorHandler

     Dim WordApp As Object
     Dim docMultiple As Object
     Dim docSingle As Object
     Dim rngPage As Object
     Dim iCurrentPage As Integer
     Dim iPageCount As Integer
     Dim strNewFileName As String
     Dim strNewName As String
     Set WordApp = CreateObject("Word.Application")
     
     'ParseDoc("C:\CharityMaster\April 31.docx")

     WordApp.Application.ScreenUpdating = False
     Set docMultiple = WordApp.Documents.Open(filename)

 '       WordApp.Visible = True

     Set rngPage = docMultiple.Range
     iCurrentPage = 1
     iPageCount = docMultiple.Content.ComputeStatistics(2) '(WdStatistic.wdStatisticPages)

     Do Until iCurrentPage > iPageCount

         If iCurrentPage = iPageCount Then
             rngPage.end = WordApp.ActiveDocument.Range.end
         Else
            'WdGoToItem.wdGoToPage  WdGoToDirection.wdGoToAbsolute
             WordApp.selection.GoTo 1, 1, iCurrentPage + 1
             rngPage.end = WordApp.selection.Start
         End If
         rngPage.Copy
         Set docSingle = WordApp.Documents.Add
         docSingle.Range.Paste
         docSingle.Range(docSingle.Range.end - 1, docSingle.Range.end).Delete
         docSingle.Range.Find.Execute findText:="^m", ReplaceWith:=""
         
         strNewName = "Test"

         strNewFileName = docMultiple.path & "\" & strNewName & "_" & Right$("000" & iCurrentPage, 4) & ".docx"
         docSingle.SaveAs (strNewFileName)
         iCurrentPage = iCurrentPage + 1
         docSingle.Close
         rngPage.collapse (0) ' wdCollapseEnd
     Loop

     WordApp.Application.ScreenUpdating = True

     WordApp.Quit

     Set docMultiple = Nothing
     Set docSingle = Nothing
     Set rngPage = Nothing
     Set WordApp = Nothing


ErrorHandler_Exit:
   On Error GoTo 0
   Exit Sub

ErrorHandler:

    Call ErrorLog(Err.Description, Err.Number, "MailMerge", "Sub: ParseDoc", Erl)

 End Sub

Select allOpen in new window

Thank you GrahamSkan! The code provided works fine except at the end I get error 4605 : "The method or property is not available because no text was selected." The following line throws the error:

rng.Copy

Select allOpen in new window

It seems like the code is processing one too many sections. Is is trying to read the section after the end of the document?

I would also appreciate some help on the naming of each document. I want to put a field called "FullName" at the beginning of the document and set the font color to white. It will not show on the split documents but it could be used to name each document. I saw some code to do this several days ago but now I can't find it.

I figured out the file naming issue and changed the error handling to trap the issue of going to the section after the last page. Thanks for everyone's help.