Microsoft Office Forums - View Single Post

macropod · 05-07-2014, 06:52 PM

None of the target paragraphs in your attachment is numbered, though some have bullet points. The only numbered paragraphs are the headings - and they use list-level numbering. There are also no numbered paragraphs associated with the Appendices. Assuming all your documents are formatted that way, try:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim ExcelApp As Object, ExcelWB As Object, ExcelWS As Object
Dim StrFnd As String, StrOut As String, i As Long, j As Long
Dim Rng As Range
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
Set ExcelWB = ExcelApp.Workbooks.Add
Set ExcelWS = ExcelWB.Sheets(1)
StrFnd = "shall,will,must,may,should,provide"
For i = 0 To UBound(Split(StrFnd, ","))
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = Split(StrFnd, ",")(i)
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Do While .Find.Found
      j = j + 1
      Set Rng = .Duplicate
      With Rng
        .Expand Unit:=wdSentence
        If Asc(.Characters.Last.Text) < 33 Then .End = .End - 1
        If .Characters.Last.Next.Text = LCase(.Characters.Last.Next.Text) Then
          .MoveEnd wdSentence, 1
        End If
        While .Words.First.Previous.Text Like "[eig]"
          .MoveStart wdSentence, -1
        Wend
        If .Characters.Last.Text Like "[" & vbCr & Chr(11) & vbTab & "]" Then .End = .End - 1
        StrOut = Trim(.Text)
      End With
      ExcelWS.Cells(j, 2).Value = StrOut
      StrOut = ""
      If .Paragraphs.First.Range.ListParagraphs.Count = 1 Then
        StrOut = .Paragraphs.First.Range.ListFormat.ListString
      End If
      If Not .Paragraphs.First.Range.ListFormat.ListString Like "[0-9]*" Then
        While (Not .Paragraphs.First.Range.ListFormat.ListString Like "[0-9]*") And _
          (Not .Paragraphs.First.Range.Words.First Like "Appendix*")
          .MoveStart wdParagraph, -1
        Wend
        If .Paragraphs.First.Range.Words.First Like "Appendix*" Then
          StrOut = "Appendix " & Split(.Paragraphs.First.Range.Text, " ")(1) & StrOut
        Else
          StrOut = .Paragraphs.First.Range.ListFormat.ListString & StrOut
        End If
      End If
      ExcelWS.Cells(j, 1).Value = StrOut
      .Collapse wdCollapseEnd
      '.Start = Rng.End
      .Find.Execute
    Loop
  End With
Next
With ExcelApp
  .Visible = True
  .DisplayAlerts = False
  ExcelWB.SaveAs "C:\users\" & Environ("UserName") & "\desktop\shredder.csv", 6
  .DisplayAlerts = True
End With
Set ExcelWS = Nothing: Set ExcelWB = Nothing: Set ExcelApp = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

Note: In addition to streamlining your code, I've done a fair bit of work to ensure the code captures complete sentences and their references.