Word VBA Copy Heading and Content

[desert_dweller5]

I am trying to figure out a macro to split the document by heading regardless of the heading level into separate documents for an audiobook.

sub selectHeadingAndContent
Selection.GoTo What:=wdGoToHeading, Which:=1 'this is the start of the selection
Selection.GoToNext (wdGoToHeading) 'this is the end of the selection.
end sub

I'm trying to put these 2 positions into a range object so that I can copy the range.

if anyone can please help me figure this range bit out I'd surely appreciate it.
Thanks!
Desert_dweller5

 

[macropod]

You could use a macro like the following to split the document at the Heading1 level:

Sub SplitDocumentByHeading()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Rng As Range, i As Long
Dim StrTmplt As String, StrNm As String, StrEx As String, lFmt As Long
Set DocSrc = ActiveDocument
With DocSrc
  StrTmplt = .AttachedTemplate.FullName
  StrNm = Split(.FullName, ".doc")(0)
  StrEx = Split(.FullName, ".doc")(1)
  lFmt = .SaveFormat
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Style = wdStyleHeading1
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Do While .Find.Found
      i = i + 1
      Set Rng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
      Set DocTgt = Documents.Add(Template:=StrTmplt, Visible:=False)
      With DocTgt
        .Range.FormattedText = Rng.FormattedText
        .SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".doc" & StrEx, Fileformat:=lFmt, AddToRecentFiles:=False
        .Close
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Set DocTgt = Nothing: Set Rng = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

Rather more complex code would be required to split it at the sub-heading level.

To save the output as plain text files, you could delete all the references to StrEx & lFmt, and change:
.SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".doc" & StrEx, Fileformat:=lFmt, AddToRecentFiles:=False
to:
.SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".txt", Fileformat:=wdFormatText, AddToRecentFiles:=False

 

[desert_dweller5]

You could use a macro like the following to split the document at the Heading1 level:


Rather more complex code would be required to split it at the sub-heading level.

To save the output as plain text files, you could delete all the references to StrEx & lFmt, and change:
.SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".doc" & StrEx, Fileformat:=lFmt, AddToRecentFiles:=False
to:
.SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".txt", Fileformat:=wdFormatText, AddToRecentFiles:=False

thanks for this code macropod. I am trying to split the document at everyheading level. I came up with a bit of a different approach but it still has bugs. Here's what I have so far:

Sub Audibook()
Call selectHeaderAndContents
Call writeTextFile
End Sub
Sub getFileName()
Dim fileName As String
Selection.Expand wdLine
fileName = Selection.Text
fileName = Replace(fileName, vbCr, "")
ActiveDocument.Variables("FileName").Delete
ActiveDocument.Variables.Add Name:="FileName", Value:=fileName
For Each myVar In ActiveDocument.Variables
 Debug.Print "Name =" & myVar.Name & vbCr & "Value = " & myVar.Value
Next myVar


End Sub
Sub selectHeaderAndContents()

Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
Call getFileName
Selection.HomeKey

pos = Selection.Range.Start
Selection.GoTo What:=wdGoToHeading, Which:=wdGoToNext, Count:=1, Name:=""
pos2 = Selection.Range.End
Set myRange = ActiveDocument.Range(Start:=pos, End:=pos2)
ActiveDocument.Variables("Text").Delete
ActiveDocument.Variables.Add Name:="Text", Value:=myRange
For Each myVar In ActiveDocument.Variables
 Debug.Print "Name =" & myVar.Name & vbCr & "Value = " & myVar.Value
Next myVar
End Sub
Public Sub writeTextFile()
Dim filePath, fileName, fileType As String
filePath = "C:\Users\E6420\Documents\macro\"
fileName = ActiveDocument.Variables("FileName")
fileType = ".txt"
builtPath = filePath & fileName
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim fileStream As TextStream
Set fileStream = fso.CreateTextFile(builtPath)
fileStream.WriteLine "something"
fileStream.Close
If fso.FileExists(filePath) Then
    MsgBox "done!"
    End If
Set fileStream = Nothing
Set fso = Nothing
End Sub

there are a few problems here.
The main problem at the moment is that the macro skips the even numbers of heading.

Second, every time the macro runs It errors out on the application variables. I need to include an if statement to control the flow if the variable exists then change the value else add the variable. but I don't currently know how to do this.

third is there's a problem with the builtPath variable when I include the file extension with a variable. if I type it or copy and paste from the document it will work but not if I try to concatenate this with filePath & fileName & fileType on the same line. if I don't include the file extension it will make a file but without an extension. maybe there's a disallowed character? I haven't figured it out.
any help would be appreciated.

 

[macropod]

Try:

Sub SplitDocumentByHeading()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Rng As Range, i As Long, p As Long
Dim StrNm As String
Set DocSrc = ActiveDocument
With DocSrc
  StrNm = Split(.FullName, ".doc")(0)
  With .Range
    For p = 1 To .Paragraphs.Count
      If .Paragraphs(p).Style.NameLocal Like "Heading#" Then i = i + 1
    Next
    For p = .Paragraphs.Count To 1 Step -1
      If .Paragraphs(p).Style.NameLocal Like "Heading#" Then
        Set Rng = .Paragraphs(p).Range.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
        Set DocTgt = Documents.Add(Visible:=False)
        With DocTgt
          .Range.Text = Rng.Text
          .SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".txt", Fileformat:=wdFormatText, AddToRecentFiles:=False
          .Close
        End With
        i = i - 1
      End If
    Next
  End With
End With
Set DocTgt = Nothing: Set Rng = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

 

[macropod]

Also, insert:
Rng.Text = vbNullstring
after:
.Range.Text = Rng.Text
and, if there is content before the first heading, you might want to change:
Set DocSrc = ActiveDocument
to:
Set DocSrc = ActiveDocument: i = 1
and insert:
.SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".txt", Fileformat:=wdFormatText, AddToRecentFiles:=False
before the final:
End With
Note that this will appear to leave you with a document that only contains whatever appears before the first heading. Don't worry - your original document will still be intact.