excel - 找到特定单词后找到句子的其余部分

Question

我创建了一个代码，可以在 word 文档的列中搜索不同的单词。
找到单词后，代码将值“yes”返回给 excel。
我希望代码在找到我正在寻找的单词后提取句子的其余部分。
其余的句子总是这样的:

更新系统格式。

搜索其他输入。

Havent找到了它需要做的句子。

总之，它们总是一个小句子和一个新的段落。
我开发的代码如下:

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)

目前只在找到句子时写"is"并将信息粘贴到一列中，如果没有找到则转到下一个单词。

Answer 1

使用 Sentences 可以实现您想要做的事情。文档的集合。希望您可以根据需要调整以下示例代码:

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

在一个单独的模块中，我有以下代码(从我的代码库中提取以重用):

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