mining 4k page word document

[lemonap618]

Hi All,


quick question - I have a 4K page word document with hundreds of user stories. there are 3 types of user story categories that are presented in the 4k document.

My task is to separate these user stories into the 3 separate files based on the user story categories. My question - how would I separate these stories systematically? they are separated into headers and sub-headers. IAny and all help is much appreciated

[Guessed]

You haven't given enough information.

How do you know what category a story is? Is that part of the heading? When you change from one category to another, is there a consistent separator?

Without seeing a sample doc, it is unlikely we can suggest an efficient method of sorting this.

[lemonap618]

Hi Andrew,
Thank you for your response. I have attached a sample word document that will hopefully provide the information you need. If you look at the the "attributes" sections within each header you will see in the table there is a noted release. The values here are either "profit analyzer", "deal manager", "price manager", or its blank.

My question is - is there a way to separate this document by the release field in the table for each header?

Thanks for your time!

[macropod]

I doubt anyone would have connected your 'user story categories' with what's in your document. Try:

Sub ExtractUserStories()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Tbl As Table, Rng As Range
Dim ArrRls, i As Long, r As Long, bExp As Boolean
ArrRls = Array("Profit Analyzer", "Deal Manager", "Price Manager")
Set DocSrc = ActiveDocument
For i = 0 To UBound(ArrRls)
  Documents.Add (DocSrc.AttachedTemplate.FullName)
  ActiveDocument.SaveAs2 FileName:=DocSrc.Path & "\" & ArrRls(i) & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
Next
With DocSrc.Range
  .ListFormat.ConvertNumbersToText
  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
    Set Rng = .Paragraphs(1).Range
    Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    For i = 0 To UBound(ArrRls)
      For Each Tbl In Rng.Tables
        bExp = False
        With Tbl
          If InStr(.Range.Text, ArrRls(i)) > 0 Then
            Set DocTgt = Documents(ArrRls(i) & ".docx"): bExp = True
            With DocTgt
              With .Range
                .Characters.Last.FormattedText = Rng.FormattedText
                .InsertAfter Chr(12)
              End With
              .Save
              DoEvents
            End With
            Exit For
          End If
        End With
      Next
    Next
    .Start = Rng.End
    .Find.Execute
  Loop
End With
For i = 0 To UBound(ArrRls)
  Documents(ArrRls(i) & ".docx").Close True
Next
DocSrc.Undo (1)
Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

[lemonap618]

Thank you so much for the response - very helpful!