Microsoft Office Forums - View Single Post - [Solved] Divide Text Doc into Multiple Parts at .pa Delimiter

macropod · 09-08-2018, 08:43 PM

Quote:

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.

Code:

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