How to extract "Actions Items" from an MS Word file to compile list at end of document

I found an older thread about "Extraction of "Actions items" from the word main body to a table". Unfortunately, the code has errors in it in the current version of MS Word. I was able to get AI to re-code a Macro for this. The macro below will copy any paragraph in a MS Word file that says "Action Item", paste a copy of it at the end of the document under an "Action Item" section.

For those not used to working with Macros:

1. In MS Word, go to the Developer ribbon
2. Click on Record Macro
3. Enter a Macro name in the popup and click OK.
4. Stop the Macro recording.
5. On the Developer ribbon, click on Macro, select the name of the macro you just started, and click Edit.
6. Copy and paste the code below into the Visual Basic popup window.
7. Click Save and close.

To run the Macro:

1. On the Developer ribbon, click on Macro and select the name of the macro from the popup window list.
2. Click Run.

Here is the code to enter:

Sub ActionItemExtraction()

 

    Dim doc As Document

    Dim searchRange As Range

    Dim sourceRange As Range

    Dim targetRange As Range

    Dim actionItems As String

    Dim itemText As String

    Dim actionCount As Long

 

    Set doc = ActiveDocument

 

    'Search only the original contents of the document.

    Set searchRange = doc.Range(0, doc.Content.End - 1)

 

    With searchRange.Find

 

        .ClearFormatting

        .Text = "Action Item:"

        .Forward = True

        .Wrap = wdFindStop

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

 

        Do While .Execute

 

            'Capture the entire paragraph containing "Action Item:".

            Set sourceRange = searchRange.Paragraphs(1).Range

 

            'Get the paragraph text.

            itemText = sourceRange.Text

 

            'Remove the paragraph mark.

            itemText = Replace(itemText, vbCr, "")

 

            'Remove "Action Item:" from the copied text only.

            itemText = Replace(itemText, "Action Item:", "", _

                               1, -1, vbTextCompare)

 

            'Remove leading and trailing spaces.

            itemText = Trim(itemText)

 

            'Add the cleaned item to the list.

            actionItems = actionItems & itemText & vbCr

 

            actionCount = actionCount + 1

 

            'Continue searching after this paragraph.

            searchRange.Start = sourceRange.End

            searchRange.End = doc.Content.End - 1

 

        Loop

 

    End With

 

    'If no Action Items were found, stop here.

    If actionCount = 0 Then

        MsgBox "No Action Items were found.", _

               vbInformation, "Action Item Extraction"

        Exit Sub

    End If

 

    'Add the Action Items section at the end of the document.

    Set targetRange = doc.Range(doc.Content.End - 1, doc.Content.End - 1)

 

    targetRange.InsertAfter vbCr & "Action Items" & vbCr & actionItems

 

    MsgBox actionCount & " action item(s) added to the end of the document.", _

           vbInformation, "Action Item Extraction"

 

End Sub