Word 2010 Macro: Count instances of words in section?

Good morning, I have a large volume of documents that I want to collect some information on.  I've attached 2 examples to this post so you can take a look.  

Each .docx has a section called Policy where there is one of three decisions Required, Not Required, or Uncertain (decisions are always bolded).  I want to collect this information so it can be imported to a spreadsheet with the following columns for each document in a directory.

Document Title
# Uncertain
# Necessary
# Not Necessary

Can any experts help with this problem?

Thanks in advance,
Bevos
Example-1.docx
Example-2.docx
BevosAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

GrahamSkanRetiredCommented:
A bit much for one question, but it does require one or two techniques that weren't needed in your previous questions, so try this:
Sub CountNecessities()
Dim doc As Document
Dim tbl As Table
Dim rng As Range
Dim rng2 As Range
Dim rngSentence As Range
Dim para As Paragraph
Dim counts(2) As Integer

Set doc = ActiveDocument
If doc.Tables.Count > 0 Then
    Set tbl = doc.Tables(1)
    Set rng = doc.Range
    Set rng2 = doc.Range
    With rng.Find
        .Style = "Head 1"
        .Text = "Policy^p"
        If .Execute Then
            tbl.Cell(2, 1).Range.Text = doc.Name
            rng2.Start = rng.End
            For Each para In rng2.Paragraphs
                If para.Style = "Body Txt Flush Left" Then
                    Set rngSentence = para.Range.Sentences.Last
                    If rngSentence.Bold Then
                        Select Case Trim(Replace(rngSentence.Text, vbCr, ""))
                            Case "Necessary"
                                counts(0) = counts(0) + 1
                            Case "Not Necessary"
                                counts(1) = counts(1) + 1
                            Case "Uncertain"
                                counts(2) = counts(2) + 1
                            Case Else
                                MsgBox rngSentence.Text & " is not a valid option"
                        End Select
                    End If
                Else
                    Exit For
                End If
            Next para
            For i = 0 To 2
                tbl.Cell(2, i + 2).Range.Text = counts(i)
            Next i
        Else
            MsgBox "'POLICY' heading with style 'Head 1' not found"
            Exit Sub
        End If
    End With
End If
End Sub

Open in new window

BevosAuthor Commented:
Wow, this is great.  Could I ask for one minor edit, instead of adding the content to the table that is already there, can it be at a new table at the start of the document?  

Sorry for the confusion but that table is already part of the template.

Thanks,
Bevos
BevosAuthor Commented:
One other question, I tried editing the strings found  Case "Necessary" to include if a period is after (e.g. the sentence ends with 'necessary.' or 'necessary' occurs in a sentence, but had some trouble.  I tried using regular expression but it didn't seem to work here.  How should I approach this?
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

BevosAuthor Commented:
I modified the code to include the table at the start of the document:
Sub DelText2()
Dim rng As Range
Dim rng1 As Range
Set rng = ActiveDocument.Range

With rng.Find
    .Text = "POLICY"
    .Style = "Head 1"
    If .Execute() Then
        Set rng1 = rng.Duplicate
    End If
    rng.End = ActiveDocument.Range.End
    .Text = "POLICY GUIDELINES"
    If .Execute() Then
        rng1.End = rng.Start
    End If
   
End With

rng1.Delete
Set rng = ActiveDocument.Range

With rng.Find
    .Text = "POLICY GUIDELINES"
    .Style = "Head 1"
    If .Execute() Then
        Set rng1 = rng.Duplicate
    End If
    rng.End = ActiveDocument.Range.End
    .Text = "BENEFIT APPLICATION"
    If .Execute() Then
        rng1.End = rng.Start
    End If
   
End With

rng1.Delete
Set rng = ActiveDocument.Range

With rng.Find
    .Text = "BENEFIT APPLICATION"
    .Style = "Head 1"
    If .Execute() Then
        Set rng1 = rng.Duplicate
    End If
    rng.End = ActiveDocument.Range.End
    .Text = "BACKGROUND"
    If .Execute() Then
        rng1.End = rng.Start
    End If
   
End With

rng1.Delete

Set rng = ActiveDocument.Range

With rng.Find
    .Text = "REGULATORY STATUS"
    .Style = "Head 1"
    If .Execute() Then
        Set rng1 = rng.Duplicate
    End If
    rng.End = ActiveDocument.Range.End
    .Text = "RATIONALE"
    If .Execute() Then
        rng1.End = rng.Start
    End If
   
End With

rng1.Delete

Set rng = ActiveDocument.Range

With rng.Find
    .Text = "CODES"
    .Style = "Head 1"
    If .Execute() Then
        Set rng1 = rng.Duplicate
    End If
    rng.End = ActiveDocument.Range.End
    .Text = "POLICY HISTORY"
    If .Execute() Then
        rng1.End = rng.Start
    End If
   
End With

rng1.Delete

Set rng = ActiveDocument.Range

With rng.Find
    .Text = "POLICY HISTORY"
    .Style = "Head 1"
    If .Execute() Then
        Set rng1 = rng.Duplicate
    End If
    rng.End = ActiveDocument.Cha
    If .Execute() Then
        rng1.End = rng.Start
    End If
   
End With

rng1.Delete
End Sub


Sub Delete()
Dim rng As Range
Dim rng1 As Range
Set rng = ActiveDocument.Range
With rng.Find
    .Text = "REFERENCES"
    .Style = "Head 1"
    If .Execute() Then
        Set rng1 = rng.Duplicate
    End If
    rng.End = ActiveDocument.Range.Characters.Last.
    If .Execute() Then
        rng1.End = rng1.End
    End If
End With
rng1.Delete
End Sub

Sub CountNecessities()
Dim doc As Document
Dim tbl As Table
Dim rng As Range
Dim rng2 As Range
Dim rngSentence As Range
Dim para As Paragraph
Dim counts(2) As Integer

Set myRange = ActiveDocument.Range(0, 0)
ActiveDocument.Tables.Add Range:=myRange, NumRows:=1, NumColumns:=4
Set myTable = ActiveDocument.Tables(1)
With myTable.Borders
 .InsideLineStyle = wdLineStyleSingle
 .OutsideLineStyle = wdLineStyleDouble
End With
For Each oCell In myTable.Range.Cells
  oCell.Range.Font.Name = "Arial"
  oCell.Range.Font.Size = 10
Next oCell

Set doc = ActiveDocument
If doc.Tables.Count > 0 Then
    Set tbl = doc.Tables(1)
    Set rng = doc.Range
    Set rng2 = doc.Range
    With rng.Find
        .Style = "Head 1"
        .Text = "Policy^p"
        If .Execute Then
            tbl.Cell(2, 1).Range.Text = doc.Name
            rng2.Start = rng.End
            For Each para In rng2.Paragraphs
                If para.Style = "Body Txt Flush Left" Then
                    Set rngSentence = para.Range.Sentences.Last
                    If rngSentence.Bold Then
                        Select Case Trim(Replace(rngSentence.Text, vbCr, ""))
                            Case "Necessary"
                                counts(0) = counts(0) + 1
                            Case "Not Necessary"
                                counts(1) = counts(1) + 1
                            Case "Uncertain"
                                counts(2) = counts(2) + 1
                            Case Else
                                MsgBox rngSentence.Text & " is not a valid option"
                        End Select
                    End If
                Else
                    Exit For
                End If
            Next para
            For i = 0 To 2
                tbl.Cell(2, i + 2).Range.Text = counts(i)
            Next i
        Else
            MsgBox "'POLICY' heading with style 'Head 1' not found"
            Exit Sub
        End If
    End With
End If
End Sub

Open in new window


However, I'm still stuck on the other question (matching instances where there is a period after the searched for word).

Thanks,
Bevos
GrahamSkanRetiredCommented:
Not sure what you mean by 'regular expression' in this instance. You could add the item to the Case line:
                           
Case "Necessary", "Necessary." 

Open in new window

or you could nest another Replace to remove any full-stops inside the existing Replace in the Select Case line:
                       
Select Case Trim(Replace(Replace(rngSentence.Text, ".", ""), vbCr, ""))

Open in new window

GrahamSkanRetiredCommented:
I am in the process of working on the table creation. I have been trying to match the one in Example 1, so I'll post it even though you have already written your own.
GrahamSkanRetiredCommented:
Had a bit of trouble matching the text colour in the table headings.

Apart from what we have already discussed, I have removed the (letter) case sensitivity of option strings by using LCase in the Select Case line. You didn't capitalise the word 'necessary' in your comment, so I thought that you might not want to enforce it.
Sub CountNecessities()
    Dim doc As Document
    Dim tbl As Table
    Dim rng As Range
    Dim rng2 As Range
    Dim rngSentence As Range
    Dim para As Paragraph
    Dim counts(2) As Integer
    
    Set doc = ActiveDocument
    If doc.Tables.Count > 0 Then
        Set tbl = doc.Tables(1)
    Else
        Set tbl = CreateTable(doc)
    End If
    Set rng = doc.Range
    Set rng2 = doc.Range
    With rng.Find
        .Style = "Head 1"
        .Text = "Policy^p"
        If .Execute Then
            tbl.Cell(2, 1).Range.Text = doc.Name
            rng2.Start = rng.End
            For Each para In rng2.Paragraphs
                If para.Style = "Body Txt Flush Left" Then
                    Set rngSentence = para.Range.Sentences.Last
                    If rngSentence.Bold Then
                        Select Case LCase(Trim(Replace(Replace(rngSentence.Text, ".", ""), vbCr, "")))
                            Case "necessary"
                                counts(0) = counts(0) + 1
                            Case "not necessary"
                                counts(1) = counts(1) + 1
                            Case "uncertain"
                                counts(2) = counts(2) + 1
                            Case Else
                                MsgBox rngSentence.Text & " is not a valid option"
                        End Select
                    End If
                Else
                    Exit For
                End If
            Next para
            For i = 0 To 2
                tbl.Cell(2, i + 2).Range.Text = counts(i)
            Next i
        Else
            MsgBox "'POLICY' heading with style 'Head 1' not found"
            Exit Sub
        End If
    End With
End Sub

Function CreateTable(doc As Document) As Table
    Dim b As WdBorderType
    Dim c As Integer
    Dim rng As Range
    
    Set rng = doc.Range(0, 0)
    Set CreateTable = doc.Tables.Add(rng, 2, 4)
    With CreateTable
        .Range.Style = "Tbl Txt Left"
        .Rows.HeightRule = wdRowHeightExactly
        .Rows.Height = CentimetersToPoints(0.3)
        .Rows.HeightRule = wdRowHeightAuto
        For b = wdBorderTop To wdBorderVertical Step -1
            .Borders(b).LineStyle = wdLineStyleSingle
            .Borders(b).LineWidth = wdLineWidth050pt
            .Borders(b).Color = wdColorDarkRed
        Next b
        .Rows(1).Range.Paragraphs.Alignment = wdAlignParagraphCenter
        .Rows(1).Range.Font.Color = RGB(0, &H99, &HD8)
        .Rows(1).Range.Font.Bold = True
        For c = 1 To 4
            .Cell(1, c).Range.Text = "Option " & c
        Next c
    End With
End Function

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
BevosAuthor Commented:
Thanks GrahamSkan for all the feedback you provided.  I think I understand some of the VBA better after playing with the code you've sent me.

Thanks again,
Bevos
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Word

From novice to tech pro — start learning today.