Divide Text Doc into Multiple Parts at .pa Delimiter

[raywood]

I have a number of text documents that have .pa where manual page breaks should be. If memory serves, that was how we did manual page breaks in XyWrite.



I'd like to develop a macro that would use those .pa delimiters as document ending points. So there would be some text; the macro would grab that text, down to the first occurrence of .pa, and move it to a new file; that first occurrence of .pa would itself be deleted; the newly created file would be saved with some automatic name; and the process would repeat, down to the (new) first occurrence of .pa, until the original file was empty.

I've used Word macros, but I don't know a lot about them. After some digging, I found this, and tried to modify it to fit, but I don't know what to substitute for " ActiveDocument.Bookmarks."

Sub BreakOnPage()
   ' Used to set criteria for moving through the document by page.
   Application.Browser.Target = wdBrowsePage

   For i = 1 To ActiveDocument.BuiltInDocumentProperties("Number of Pages")
      
      'Select and copy the text to the clipboard
      ActiveDocument.Bookmarks(".pa").Range.Copy

      ' Open new document to paste the content of the clipboard into.
      Documents.Add
      Selection.Paste

      ' Removes the break that is copied at the end of the page, if any.
      Selection.TypeBackspace
      ChangeFileOpenDirectory "D:\"
      DocNum = DocNum + 1
      ActiveDocument.SaveAs FileName:="test_" & DocNum & ".doc"
      ActiveDocument.Close

      ' Move the selection to the next page  in the document
      Application.Browser.Next
   Next i
   ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub

[macropod]

Try:

Sub SplitDocument()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, i As Long
Dim Rng As Range, HdFt As HeaderFooter, j As Long
Set DocSrc = ActiveDocument
With DocSrc
  ' Create, copy & delete a temporary Section break.
  With .Range
    Set Rng = .Characters.First
    With Rng
      .Collapse wdCollapseStart
      .InsertBreak Type:=wdSectionBreakNextPage
      .Start = .Start - 1
      .Copy
      .Delete
    End With
    ' Replace all instances of .pa with the copied Section break
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ".pa"
      .Replacement.Text = "^c"
      .Forward = True
      .Format = False
      .Wrap = wdFindContinue
      .Execute Replace:=wdReplaceAll
      If .Found = False Then Exit Sub
    End With
  End With
  ' Process each Section
  For i = 1 To .Sections.Count
    ' Get the whole Section
    Set Rng = .Sections(i).Range
    ' Contract the range to exclude the Section break
    With Rng
      .MoveEnd wdCharacter, -1
      Do While .Characters.Last.Previous.Text = vbCr
        .Characters.Last.Previous.Text = vbNullString
      Loop
      If Len(.Text) > 1 Then
        j = j + 1
        ' Copy the range
        .Copy
        ' Create the output document
        Set DocTgt = Documents.Add(Template:=DocSrc.AttachedTemplate.FullName, Visible:=False)
        With DocTgt
          ' 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
            .Characters.Last.Previous = vbNullString
          Wend
          ' Replicate the headers & footers
          For Each HdFt In DocSrc.Sections(i).Headers
            .Sections(1).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
          Next
          For Each HdFt In DocSrc.Sections(i).Footers
            .Sections(1).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
          Next
          ' Save & close the output document
          .SaveAs FileName:=Split(DocSrc.FullName, ".doc")(0) & "_" & j & ".docx", _
            FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
          .Close SaveChanges:=False
        End With
      End If
    End With
  Next
End With
Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

Based on: https://www.msofficeforums.com/mail-...ps-tricks.html

[gmayor]

Maybe something like:

Sub SplitDoc()
Const strName As String = "Test_" 'the name of the files
Const strPath As String = "C:\Path\" 'the folder to save the files
Dim strDocName As String
Dim oDoc As Document
Dim oRng As Range, oSplit As Range
Dim oNewDoc As Document
Dim strDelim As String: strDelim = ".pa"
Dim Counter As Integer: Counter = 1
Dim strOriginalName As String

    Set oDoc = ActiveDocument
    oDoc.Save
    If oDoc.path = "" Then Beep: GoTo lbl_Exit
    strOriginalName = oDoc.FullName
    Set oRng = oDoc.Range


    Application.ScreenUpdating = False

    With oRng.Find
        Do While .Execute(FindText:=strDelim, MatchWholeWord:=True, MatchCase:=True)
            oRng.Text = ""
            Set oSplit = oRng
            oSplit.Start = ActiveDocument.Range.Start
            Set oNewDoc = Documents.Add(strOriginalName)
            oNewDoc.Range.FormattedText = oSplit.FormattedText
            strDocName = strPath & strName & _
                         LTrim$(Str$(Counter)) & ".docx"
            oNewDoc.SaveAs2 strDocName
            oNewDoc.Close
            Counter = Counter + 1
            oSplit.Text = ""
            oRng.Collapse 0
        Loop
    End With
    oDoc.SaveAs2 strDocName
    oDoc.Close wdDoNotSaveChanges
    Documents.Open strOriginalName
lbl_Exit:
    Set oDoc = Nothing
    Set oNewDoc = Nothing
    Set oRng = Nothing
    Set oSplit = Nothing
    Exit Sub
End Sub

[raywood]

OK. To try each of these macros in Word 2010 (which, sorry, I didn't specify previously), I opened one of these *.txt docs and pasted its contents into an empty Word doc. Then I ran these macros, with the following results:

(1) Re: the SplitDocument macro (macropod):

"Run-time error '4605': This method or property is not available because no text is selected."

Debug button highlights the ".Copy" line (With DocSrc > With .Range > With Rng).

I guess there must be a Select command that I could insert somewhere before that?

(2) Re: the SplitDoc macro (gmayor):

It asked me for a filename. I thought it was offering to save the pasted text as a Word doc, in whole or in part. I offered Doc001. It said, "Run-time error '5152': This is not a valid file name." So then I figured it was asking for the name of an input file. I closed the opened Word doc, ran the macro again, and specified the input .txt file. But then it said, "Run-time error '4248': This command is not available because no document is open." Debug highlighted "Set oDoc = ActiveDocument."

I tried again with an open but empty Word doc. It offered the Save As dialog. I entered Doc001.docx. It repeated the 5152 error. This time, Debug highlighted "oDoc.SaveAs2 strDocName."

For both of these macros:

Once I figure this out, I'll probably comment the macro to clarify the proper opening steps for a complete noob, so I'll be able to use the macro in the future without stumbling around like this.

Thank you, both of you, for going to the trouble of working up that code. I have a hard time learning coding unless I put in a lot of time. I did that for batch, back in the day, and also for WordPerfect scripts, which made great sense to me. But for some reason I've had a learning block when it comes to VBA. It always seems like I'd have to devote several months to it, and I can't.

[macropod]

Without knowing which code line was highlighted when the error occurred, it's impossible to comment on why it's happening. Furthermore, with my code, it was assumed the document had already been saved. Your process suggests you're maybe not doing that, in which case the macro will fail. And no, my code doesn't select anything. However, it's possible you'll get an error if there's are .pa strings with nothing else before/after them. I've updated the code to handle that.

[gmayor]

In the case of my macro, the macro starts by saving the document. If it prompts for a name it is because the original document doesn't have a name (which it won't if you have just copied text to a new empty document). Save and name the document!


The macro needs to run on a Word document in docx format not a TXT file. If you have a text file start with Save As and save as DOCX format. Then run the macro with that document on screen.

[raywood]

gmayor: still the same error when run on x.docx: Run-time error '5152.'" Same line highlighted in Debug as before: "oDoc.SaveAs2 strDocName." The macro opened a new document, but there's nothing in it. The debugger limits my navigation to see what's going on. But when I stop the debugger, the first chunk of text (i.e., text up to the first occurrence of .pa) does get added to the new doc. At that point, I see that the .pa delimiter has been removed from the source doc, but the initial text (i.e., that which has been copied to the new doc) is still in the source doc.

macropod: trying the revised SplitDocument macro on a fresh copy of x.docx, I get the same "Run-time error '4605.'" I get only an hourglass cursor at that point. I click Debug. As before, the "Copy" line is highlighted in the code. Not sure what you meant in saying that you didn't know what code line was highlighted. That's the only thing that seems to be highlighted. Nothing is highlighted in x.docx, as far as I can tell: I can't navigate while the debugger is open, and nothing is highlighted when I close it.

[macropod]

Can you attach a problem document to a post with some representative data (delete anything sensitive)? You do this via the paperclip symbol on the 'Go Advanced' tab at the bottom of this screen.

[raywood]

Sure. Here you go. These particular letters are pretty trivial, but they should work. Thanks.

[macropod]

Try the latest code revision.

[raywood]

That works. We are cruising.

To clarify for posterity, macropod's SplitDocument macro parses Test.docx file of this form:

Text
Text
Text

.pa

Text
Text
Text

.pa

Text
Text
Text

.pa

into a series of separate files Text_1.docx, Text_2.docx, et seq., where each file ends at the next .pa delimiter, and that delimiter itself is removed.

I have one last question. At present, I have to click OK for each file. It's nice that it displays a dialog showing the top of the next file in the series, but the dialog doesn't allow me to scroll, so I can't use it to confirm that we've got a proper break. For that, apparently I'll have to open the several output files individually. And that's fine. But if that's the way it is, I'd just as soon dispense with the manual confirmation.

For that, I suspect we're talking about deleting the MsgBox .Text line. Is that right, and is that all there is to it?

[gmayor]

The only ways I can see why the macro I posted would cause that error are

1. That you are using Word 2007 in which case change

oDoc.SaveAs2 strDocName
to
oDoc.SaveAs strDocName
or

2. that you have not changed the line

Const strPath As String = "C:\Path\" 'the folder to save the files

to reflect a path that exists in which to save the documents. Otherwise it splits your test document without issue.

[raywood]

gmayor -- yes, you're right, silly oversight on my part. Changing the path name fixed that. And this macro has the advantage of not requiring manual approval of each letter.

One remaining issue: in two tests, for the last .pa-delimited document, I get only a blank page. In one, for instance, there are eight pieces of correspondence ending with .pa; each of the first seven get copied into separate .docx files; there is an eighth .docx file, but it is empty; the eighth letter ending with .pa does not get copied into it.

Just in the spirit of trying to learn a bit from this, maybe the counter is incrementing at the wrong time?

[macropod]

Originally Posted by raywood

And this macro has the advantage of not requiring manual approval of each letter.

Actually, that was just an oversight, in that I left a MsgBox in the code from testing.

The following version of the previous macro will process a whole folder, so you don't have to manually open each document. As coded, the macro assumes your XyWrite documents have a .txt extension; if not, change the two .txt references in the code to the correct extension.

Sub SplitDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String
Dim DocSrc As Document, DocTgt As Document, i As Long
Dim Rng As Range, HdFt As HeaderFooter, j As Long
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.txt", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set DocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, _
      ConfirmConversions:=False, AddToRecentFiles:=False, Visible:=False)
    With DocSrc
      ' Create, copy & delete a temporary Section break.
      With .Range
        Set Rng = .Characters.First
        With Rng
          .Collapse wdCollapseStart
          .InsertBreak Type:=wdSectionBreakNextPage
          .Start = .Start - 1
          .Copy
          .Delete
        End With
        ' Replace all instances of .pa with the copied Section break
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = ".pa"
          .Replacement.Text = "^c"
          .Forward = True
          .Format = False
          .Wrap = wdFindContinue
          .Execute Replace:=wdReplaceAll
        End With
      End With
      ' Process each Section
      j = 0
      For i = 1 To .Sections.Count
        ' Get the whole Section
        Set Rng = .Sections(i).Range
        ' Contract the range to exclude the Section break
        With Rng
          .MoveEnd wdCharacter, -1
          Do While .Characters.Last.Previous.Text = vbCr
            .Characters.Last.Previous.Text = vbNullString
          Loop
          If Len(.Text) > 1 Then
            j = j + 1
            ' Copy the range
            .Copy
            ' Create the output document
            Set DocTgt = Documents.Add(Template:=DocSrc.AttachedTemplate.FullName, Visible:=False)
            With DocTgt
              ' 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
                .Characters.Last.Previous = vbNullString
              Wend
              ' Replicate the headers & footers
              For Each HdFt In DocSrc.Sections(i).Headers
                .Sections(1).Headers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
              Next
              For Each HdFt In DocSrc.Sections(i).Footers
                .Sections(1).Footers(HdFt.Index).Range.FormattedText = HdFt.Range.FormattedText
              Next
              ' Save & close the output document
              .SaveAs FileName:=Split(DocSrc.FullName, ".txt")(0) & "_" & j & ".docx", _
                FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
              .Close SaveChanges:=False
            End With
          End If
        End With
      Next
      .Close SaveChanges:=False
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

[gmayor]

Originally Posted by raywood

gmayor --
One remaining issue: in two tests, for the last .pa-delimited document, I get only a blank page. In one, for instance, there are eight pieces of correspondence ending with .pa; each of the first seven get copied into separate .docx files; there is an eighth .docx file, but it is empty; the eighth letter ending with .pa does not get copied into it.

Just in the spirit of trying to learn a bit from this, maybe the counter is incrementing at the wrong time?

The blank page is caused by the fact that you have .pa at the end.

That being the case remove the line to save the document before it is closed

'oDoc.SaveAs2 strDocName
    oDoc.Close wdDoNotSaveChanges

Incidentally this also demonstrated another issue related to that blank page in that there was a missing line in the original code that would have correctly named the last document. This would still have given you a blank page, (the page after the last .pa) but the last true page would have been correct also.

End With
    strDocName = strPath & strName & _
                 LTrim$(Str$(Counter)) & ".docx"
    oDoc.SaveAs2 strDocName
    oDoc.Close wdDoNotSaveChanges
    Documents.Open strOriginalName