Finding rest of sentence after finding an specific word-CodePudding

I have created a code that searches different words in a column in a word document. After finding the word, the code returns the value "yes" to the excel. I want the code to extract the rest of the sentence after finding the word that I´m looking for.

The rest of the sentences are always something like:

Update system format.
Search for other inputs.
Havent found the sentence that it needs to do.

In conclusion, they are always a small sentence and a new paragraph after.

The code that I have developed is the following:

Sub findSubprocesos()

    Dim wrdApp As New Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    Dim FindWord As String
    Dim List As String
    
    Dim Dict As Object
    Dim NextFormula As Range
    Dim RefElem As Range
    Dim Key
    Dim Wbk As Workbook: Set Wbk = ThisWorkbook




    Set Dict = CreateObject("Scripting.Dictionary")
    Set NextFormula = Worksheets("Datos2").Range("V2:V5")
    
    

    With Dict
        For Each RefElem In NextFormula
             If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
                Sheets("Datos2").Range("R3").Value = RefElem.Value
                Debug.Print RefElem
                FindSubs
                On Error GoTo Skip


            
    End If
    Next RefElem
Skip:
    End With
    
    
        
        
    
End Sub

Private Sub FindSubs()

    Dim wrdApp As New Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    Dim FindWord As String
    Dim List As String
    
    Dim Dict As Object
    Dim NextFormula As Range
    Dim RefElem As Range
    Dim Key
    Dim Wbk As Workbook: Set Wbk = ThisWorkbook

        
    Range("U3:U50").ClearContents
    
    wrdApp.Visible = True

    Set wrdDoc = wrdApp.Documents.Open("C:\Users\rriveragarrido\Desktop\Proyectos\Proyecto solaris (endesa) (PROPIO)\prueba macros\ZZZ\Narrativas antiguas\1059\1059_NAR_OTC.RC.03.01_CC.END.GEN_ENG_31.12.20.docx", OpenAndRepair:=True)

    
    Dim cell As Range
    Dim bIsEmpty As Boolean

    bIsEmpty = False
    For n = 3 To 20
    For Each cell In Worksheets("Datos").Range("S" & n)
        If IsEmpty(cell) = False Then

    
   FindWord = Wbk.Sheets("Datos2").Range("S" & n).Value  'Modify as necessary.

    wrdApp.Selection.WholeStory
    wrdApp.Selection.FIND.ClearFormatting
    With wrdApp.Selection.FIND
        
        .ClearFormatting
        .Text = FindWord
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        
        If .Execute Then
            Sheets("Datos2").Range("U" & n).Value = "Yes"
        Else
            'Sheets("Datos2").Range("T" & n).Value = "No"
            wrdApp.Quit SaveChanges:=0
            Sheets("Datos2").Range("U3:U50").Copy Sheets("Subprocesos").Range("A3:A50").End(xlToRight).Offset(0, 1)
            GoTo Skip2
        End If
        End With
        
    End If
    Next cell
    Next
    


Skip2:

End Sub




This is the part were I need to extract the rest of the sentence:
 
        If .Execute Then
            Sheets("Datos2").Range("U" & n).Value = "Yes"
        Else
            'Sheets("Datos2").Range("T" & n).Value = "No"
            wrdApp.Quit SaveChanges:=0
            Sheets("Datos2").Range("U3:U50").Copy Sheets("Subprocesos").Range("A3:A50").End(xlToRight).Offset(0, 1)

Currently is only writing "yes" when the sentence is found and pasting the information in a column and going to the next word if it is not found.

CodePudding user response：

What you want to do is possible by using the Sentences collection of the document. Hopefully you can adapt the sample code below to your needs:

Option Explicit

Sub test()
    Dim foundSentences As Collection
    Set foundSentences = FindTheSentencesContaining(ThisWord:="access", _
                                                    FromThisDoc:="C:\Temp\test.docx")
    If foundSentences Is Nothing Then
        Debug.Print "The word doc was not found!"
    Else
        Debug.Print "found " & foundSentences.Count & " sentences"
        Dim sentence As Variant
        For Each sentence In foundSentences
            Debug.Print sentence
        Next sentence
    End If
End Sub

Function FindTheSentencesContaining(ByVal ThisWord As String, _
                                    ByVal FromThisDoc As String) As Collection
    Dim wordWasRunning As Boolean
    wordWasRunning = IsMSWordRunning
    
    Dim wordApp As Word.Application
    Set wordApp = AttachToMSWordApplication

    On Error Resume Next
    Dim wordDoc As Word.Document
    Set wordDoc = wordApp.Documents.Open(Filename:=FromThisDoc, ReadOnly:=True)
    On Error GoTo 0
    
    If wordDoc Is Nothing Then Exit Function
    
    Dim allSentences As Collection
    Set allSentences = New Collection
    
    Dim sentence As Variant
    For Each sentence In wordDoc.Sentences
        sentence.Select
        With wordApp.Selection
            .Find.Text = ThisWord
            .Find.Forward = True
            .Find.Wrap = wdFindStop
            .Find.MatchCase = False
            If .Find.Execute Then
                '--- extend the selection to include the whole sentence
                .Expand Unit:=wdSentence
                allSentences.Add wordApp.Selection.Text
                '--- move the cursor to the end of the sentence to continue looking
                .Collapse Direction:=wdCollapseEnd
                .MoveEnd Unit:=wdSentence
            Else
                '--- didn't find it, move to the next sentence
            End If
        End With
    Next sentence
    
    wordDoc.Close SaveChanges:=False
    If Not wordWasRunning Then
        wordApp.Quit
    End If
    Set FindTheSentencesContaining = allSentences
End Function

In a separate module, I have the following code (pulled from my library of code to reuse):

Option Explicit

Public Function IsMSWordRunning() As Boolean
    '--- quick check to see if an instance of MS Word is running
    Dim msApp As Object
    On Error Resume Next
    Set msApp = GetObject(, "Word.Application")
    If Err > 0 Then
        '--- not running
        IsMSWordRunning = False
    Else
        '--- running
        IsMSWordRunning = True
    End If
End Function

Public Function AttachToMSWordApplication() As Word.Application
    '--- finds an existing and running instance of MS Word, or starts
    '    the application if one is not already running
    Dim msApp As Word.Application
    On Error Resume Next
    Set msApp = GetObject(, "Word.Application")
    If Err > 0 Then
        '--- we have to start one
        '    an exception will be raised if the application is not installed
        Set msApp = CreateObject("Word.Application")
    End If
    Set AttachToMSWordApplication = msApp
End Function

CodePudding user response：

A simple demo outputting the content to a message box, for all found instances:

Sub Demo()
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = InputBox("What is the Text to Find")
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
  End With
  Do While .Find.Execute
    With .Duplicate
      .End = .Sentences.First.End
      MsgBox .Text
    End With
    .Collapse wdCollapseEnd
  Loop
End With
End Sub

Do be aware, though, that VBA has no idea what a grammatical sentence is. For example, consider the following:

Mr. Smith spent $1,234.56 at Dr. John's Grocery Store, to buy: 10.25kg of potatoes; 10kg of avocados; and 15.1kg of Mrs. Green's Mt. Pleasant macadamia nuts.

For you and me, that would count as one sentence; for VBA it counts as 5 sentences.