Sub ExtractSentence() 
    Dim ExcelApp As Object 
    Dim ExcelWB As Object
    Dim aRange As Range 
    Dim intRowCount As Integer 
    Dim MyColumn As String, Lastrow As Long 
 
    Set ExcelApp = CreateObject("Excel.Application") 
    ExcelApp.Visible = True 
    Set ExcelWB = ExcelApp.Workbooks.Add 
    intRowCount = 1 
    Set aRange = ActiveDocument.Range 
    With aRange.Find 
        Do 
            .Text = "shall" 
            .Execute 
            If .Found Then 
                aRange.Expand Unit:=wdSentence 
                aRange.Copy 
                aRange.Collapse wdCollapseEnd 
                ExcelWB.Sheets(1).Cells(intRowCount, 1).Select 
                ExcelWB.Sheets(1).Paste 
                intRowCount = intRowCount + 1 
            End If 
        Loop While .Found 
        intRowCount = intRowCount + 1 
    End With 
    Set aRange = ActiveDocument.Range 
    With aRange.Find 
        Do 
            .Text = "will" 
            .Execute 
            If .Found Then 
                aRange.Expand Unit:=wdSentence 
                aRange.Copy 
                aRange.Collapse wdCollapseEnd 
                ExcelWB.Sheets(1).Cells(intRowCount, 1).Select 
                ExcelWB.Sheets(1).Paste 
                intRowCount = intRowCount + 1 
            End If 
        Loop While .Found 
        intRowCount = intRowCount + 1 
    End With 
    Set aRange = ActiveDocument.Range 
    With aRange.Find 
        Do 
            .Text = "Must" 
            .Execute 
            If .Found Then 
                aRange.Expand Unit:=wdSentence 
                aRange.Copy 
                aRange.Collapse wdCollapseEnd 
                ExcelWB.Sheets(1).Cells(intRowCount, 1).Select 
                ExcelWB.Sheets(1).Paste 
                intRowCount = intRowCount + 1 
            End If 
        Loop While .Found 
        intRowCount = intRowCount + 1 
    End With 
    Set aRange = ActiveDocument.Range 
    With aRange.Find 
        Do 
            .Text = "Should" 
            .Execute 
            If .Found Then 
                aRange.Expand Unit:=wdSentence 
                aRange.Copy 
                aRange.Collapse wdCollapseEnd 
                ExcelWB.Sheets(1).Cells(intRowCount, 1).Select 
                ExcelWB.Sheets(1).Paste 
                intRowCount = intRowCount + 1 
            End If 
        Loop While .Found 
        intRowCount = intRowCount + 1 
    End With 
    Set aRange = ActiveDocument.Range 
    With aRange.Find 
        Do 
            .Text = "provide" 
            .Execute 
            If .Found Then 
                aRange.Expand Unit:=wdSentence 
                aRange.Copy 
                aRange.Collapse wdCollapseEnd 
                ExcelWB.Sheets(1).Cells(intRowCount, 1).Select 
                ExcelWB.Sheets(1).Paste 
                intRowCount = intRowCount + 1 
            End If 
        Loop While .Found 
        intRowCount = intRowCount + 1 
    End With 
    Set aRange = Nothing 
    fileextstr = ".csv": fileformatnum = 6 
    ExcelApp.DisplayAlerts = False 
    ExcelWB.SaveAs "C:\users\joe.valenzuela\desktop\shredder.csv" & fileextstr, fileformatnum 
    ExcelApp.DisplayAlerts = True 
End Sub