Microsoft Office Forums - View Single Post

jbvalen · 05-06-2014, 01:35 PM

I have a macro that captures statments like "shall" in a word document and dumps them into a .csv file. Right now it captures the sentence and sometimes the heading number of a paragraph (not always0. I really want the macro to not only capture the sentence, but also the paragraph or subparagrap numbers and associate it with each sentence. Below is what I have right now. Any suggestions

Code:

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