Sub ParseDocs()
Application.ScreenUpdating = False
Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String
Dim TOC As TableOfContents, Para As Paragraph, Tbl As Table, Sctn As Section, Rng As Range
Dim DocSrc As Document, DocOutline As Document, DocTxt As Document, DocTbl As Document
Dim DocApp As Document, DocRef As Document
'Call the GetFolder Function to determine the folder to process
strInFold = GetFolder
If strInFold = "" Then Exit Sub
strFile = Dir(strInFold & "\*.doc", vbNormal)
'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFold & "\Output\"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
strFile = Dir(strInFold & "\*.doc", vbNormal)
'Process all documents in the chosen folder
While strFile <> ""
  Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, AddTorecentFiles:=False, Visible:=False)
  With DocSrc
    Set DocOutline = Documents.Add(Visible:=False)
    Call CreateOutline(DocSrc, DocOutline)
    'Delete everything before the first Table Of Contents in the source document
    If .TablesOfContents.Count <> 0 Then
      Set Rng = .TablesOfContents(1).Range
      Rng.Start = .Range.Start
      Rng.Delete
    End If
    'Delete any other Tables Of Contents in the source document
    For Each TOC In .TablesOfContents
      TOC.Delete
    Next
    'Convert all fields in the source document to plain text
    .Fields.Unlink
    With Content.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      'Convert non-breaking hyphens to ordinary hyphens
      .Text = "^~"
      .Replacement.Text = "-"
      .Execute Replace:=wdReplaceAll
      'Delete manual page breaks
      .Text = "^m"
      .Replacement.Text = ""
      .Execute Replace:=wdReplaceAll
    End With
    'Check for tables in the source document
    If .Tables.Count > 0 Then
      'If there are any tables in the source document, make a copy of the document
      .Range.Copy
      ' Create a new document for the tables
      Set DocTbl = Documents.Add(Visible:=False)
      'Process the new document
      Call MakeTableDoc(DocTbl)
    End If
    'Delete all tables in the source document
    For Each Tbl In .Tables
      Tbl.Delete
    Next
    'Check for appendices in the source document
    For Each Sctn In .Sections
      If UCase(Trim(Sctn.Range.Words.First)) = "APPENDIX" Then
        Set Rng = Sctn.Range
        Rng.End = .Range.End
        'Cut the from the start of the first appendices Section to the end of the
        'source document and paste it into a new appendices document
        Rng.Cut
        Set DocApp = Documents.Add(Visible:=False)
        'Process the new document
        Call NewDoc(DocApp)
        Exit For
      End If
    Next
    'Check for references in the source document
    For Each Sctn In .Sections
      If UCase(Trim(Sctn.Range.Words.First)) = "REFERENCES" Then
        Set Rng = Sctn.Range
        Rng.End = .Range.End
        'Cut the from the start of the first references Section to the end of the
        'source document and paste it into a new references document
        Rng.Cut
        Set DocRef = Documents.Add(Visible:=False)
        'Process the new document
        Call NewDoc(DocRef)
        Exit For
      End If
    Next
    'Check for design requirements in the source document
    For Each Sctn In .Sections
      If UCase(Sctn.Range.Sentences.First) Like "#*DESIGN REQUIREMENT*" Then
        Set Rng = Sctn.Range
        Rng.End = .Range.End
        'Cut the from the start of the first references Section to the end of the
        'source document and paste it into a new references document
        Rng.Cut
        Set DocDesReq = Documents.Add(Visible:=False)
        'Process the new document
        Call NewDoc(DocDesReq)
        Exit For
      End If
    Next
    Call Cleanup(.Range)
    'String variable for the output filenames
    strOutFile = strOutFold & Split(.Name, ".")(0)
    'Copy whatever's left in the source document and paste it into a new text document
    .Range.Copy
    Set DocTxt = Documents.Add(Visible:=False)
    With DocTxt
      .Range.Paste
      'Save and close the text document
      .SaveAs FileName:=strOutFile & "-Text", AddTorecentFiles:=False
      .Close
    End With
    Set DocTxt = Nothing
    'Save and close the Outline document
    With DocOutline
      .SaveAs FileName:=strOutFile & "-Outline", AddTorecentFiles:=False
      .Close
    End With
    'Save and close the tables document
    If Not DocTbl Is Nothing Then
      DocTbl.SaveAs FileName:=strOutFile & "-Tables", AddTorecentFiles:=False
      DocTbl.Close
      Set DocTbl = Nothing
     End If
      'Save and close the appendices document
    If Not DocApp Is Nothing Then
      DocApp.SaveAs FileName:=strOutFile & "-Appendices", AddTorecentFiles:=False
      DocApp.Close
      Set DocApp = Nothing
    End If
    'Save and close the references document
    If Not DocRef Is Nothing Then
      DocRef.SaveAs FileName:=strOutFile & "-References", AddTorecentFiles:=False
      DocRef.Close
      Set DocRef = Nothing
     End If
    'Save and close the design requirements document
    If Not DocDesReq Is Nothing Then
      DocDesReq.SaveAs FileName:=strOutFile & "-Design Requirements", AddTorecentFiles:=False
      DocDesReq.Close
      Set DocDesReq = Nothing
     End If
    'Close the source document without saving the changes we've made to it
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
Set Rng = Nothing: Set DocOutline = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String
On Error Resume Next
GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path
End Function

Sub MakeTableDoc(DocTbl As Document)
Dim Sctn As Section, Para As Paragraph, Rng As Range
With DocTbl
  .Range.Paste
  'Delete any Sections with no tables in the tables document
  For Each Sctn In .Sections
    If Sctn.Range.Tables.Count = 0 Then
      Sctn.Range.Delete
    Else
      On Error Resume Next
      'Delete any Section breaks with no effect on page orientation
      If Sctn.PageSetup.Orientation = Sctn.Range.Previous.PageSetup.Orientation Then
        Sctn.Range.Previous.Characters.Last.Delete
      End If
    End If
  Next
  'Check all paragraphs not in tables in the tables document
  For Each Para In .Paragraphs
    With Para
      Set Rng = .Range
      On Error Resume Next
      With Rng
        If .Information(wdWithInTable) = False Then
          If .Next.Paragraphs.First.Range.Information(wdWithInTable) = False Then
            'Delete any paragraphs not followed by a table in the tables document
            .Delete
          Else
            'Keep table captions, if present, and ensure there are three paragraphs
            'between tables in the tables document
            If InStr(.Style, "Table Caption") = 0 Then
              .End = .End - 1
              .Text = vbNullString
            End If
            .InsertBefore vbCr & vbCr
          End If
        End If
      End With
    End With
  Next
  'Call Cleanup(.Range)
End With
Set Rng = Nothing
End Sub

Sub NewDoc(NewDoc As Document)
With NewDoc
  .Range.Paste
  Call Cleanup(.Range)
End With
End Sub

Sub Cleanup(Rng As Range)
  With Rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^b"
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
  End With
End Sub

Sub CreateOutline(DocSrc As Document, DocOutline As Document)
Dim Rng As Range, astrHeadings As Variant, strText As String
Dim intLevel As Integer, intItem As Integer
' Content returns only the main body of the document, not
' the headers and footer.
Set Rng = DocOutline.Content
astrHeadings = DocSrc.GetCrossReferenceItems(wdRefTypeHeading)
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
  ' Get the text and the level.
  strText = Trim$(astrHeadings(intItem))
  intLevel = GetLevel(CStr(astrHeadings(intItem)))
  ' Add the text to the document.
  Rng.InsertAfter strText & vbNewLine
  ' Set the style of the selected range and
  ' then collapse the range for the next entry.
  Rng.Style = "Heading " & intLevel
  Rng.Collapse wdCollapseEnd
Next intItem
End Sub

Private Function GetLevel(strItem As String) As Integer
' Return the heading level of a header from the array returned by Word.
' The number of leading spaces indicates the outline level
'(2 spaces per level): H1 has 0 spaces, H2 has 2 spaces, H3 has 4 spaces.
Dim strTemp As String, strOriginal As String, intDiff As Integer
' Get rid of all trailing spaces.
strOriginal = RTrim$(strItem)
' Trim leading spaces, and then compare with the original.
strTemp = LTrim$(strOriginal)
' Subtract to find the number of leading spaces in the original string.
intDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (intDiff / 2) + 1
End Function