Question

我是投标经理，并使用下面的宏在Word文件中搜索单词“ shall”，并将包含“须”的句子提取到Excel。它可以工作，但我不知道如何编辑代码，因此它可以按文件中出现的顺序搜索多个单词。

示例： 1.搜索“必须”或“必须”。 2.它不应该搜索“ shall”，然后再寻找“ must”。它应该搜索“必须”或“必须”，然后搜索“必须”或“必须”。 3.如果一个段落包含四个句子，并且第一个句子包含“ shall”，第二个句子包含“ shall”，第三个句子包含“ must”，第四个句子包含“ shall”，则宏应按该顺序提取到Excel。

Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
intRowCount = 1
Set aRange = ActiveDocument.Range
With aRange.Find
    Do
        .Text = "shall" ' the word I am looking for
        .Execute
        If .Found Then
            aRange.Expand Unit:=wdSentence
            aRange.Copy
            aRange.Collapse wdCollapseEnd
            If objSheet Is Nothing Then
                Set appExcel = CreateObject("Excel.Application")
                 'Change the file path to match the location of your test.xls
                Set objSheet = appExcel.workbooks.Open("C:\Temp\test.xlsx").Sheets("Sheet1")
                intRowCount = 1
            End If
            objSheet.Cells(intRowCount, 1).Select
            objSheet.Paste
            intRowCount = intRowCount + 1
        End If
    Loop While .Found
End With
If Not objSheet Is Nothing Then
    appExcel.workbooks(1).Close True
    appExcel.Quit
    Set objSheet = Nothing
    Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub

Answer 1

您可能会遇到的一个相当基本的问题是VBA不知道什么是语法句子。例如，考虑以下内容：

先生。史密斯（Smith）在约翰杂货店（Dr. John's Grocery Store）花费了1,234.56美元，购买了10.25公斤土豆；鳄梨10公斤；和15.1公斤的格林夫人山令人愉快的澳洲坚果。

对你和我来说，这将算作一句话；对于VBA，它计为5个句子。因此，以下宏仅捕获了所有相关段落。许多代码都与确定工作簿和工作表是否存在有关。不过，我还没有包括关于是否可能已经打开文件的错误检查。

Sub Demo()
'Note: This code requires a VBA reference to the Excel object library
Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook
Dim xlSht As Excel.Worksheet, StrWkBkNm As String, StrWkSht As String
Dim lRow As Long, Para As Paragraph
StrWkBkNm = "C:\Temp\test.xlsx": StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
With xlApp
  .Visible = True
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=False, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit
    Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    'Ensure the worksheet exists
    If SheetExists(StrWkSht) = True Then
    Set xlSht = .Worksheets(StrWkSht)
      With xlSht
        ' Find the last-used row in column A.
        lRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
      End With
      For Each Para In ActiveDocument.Paragraphs
        With Para
          If (InStr(.Range.Text, "shall") > 0) Or (InStr(.Range.Text, "shall") > 0) Then
            lRow = lRow + 1
            xlSht.Range("A" & lRow).Value = .Range.Text
          End If
        End With
      Next
    Else
      MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation
      .Close False
      xlApp.Quit
    End If
  End With
End With
' Release Excel object memory
Set xlSht = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing
End Sub

Answer 2

一种解决方法是：

（1）使用Word的搜索/替换功能将感兴趣的单词（shall，will）与标签（例如，will，will）包装在一起。并且可以是Word源文档中不希望出现的任何内容；

（2）使用FindWordCopySentence的修改版本来查找标记的单词，然后将相应的句子复制到Excel；然后

（3）使用Word的搜索/替换进行清理（删除标签）。或者，您可以不保存就关闭Word文档。

下面是带有一些注释的代码，以解释详细信息：

Option Explicit
Const START_TAG As String = "$$SWSTART_"
Const END_TAG As String = "_SWEND$$"


Sub AddTagsToShallWords()
' SHALL_WORDS is a |-delimited string of the words you want to replace
' The "[Ss]" means that the first letter can be upper or lower case (same for [Ww])
' This is designed to be extendible, e.g. you could add "must" by appending |[Mm]ust
Const SHALL_WORDS = "[Ss]hall|[Ww]ill"
Dim v As Variant
Dim I As Long
Dim s As String
Dim aRange As Range
Dim sFindText As String
Dim sReplaceText As String

' Create shall words to an array
v = Split(SHALL_WORDS, "|")

' Replace each shall word with its tagged version
For I = 0 To UBound(v)
    s = CStr(v(I))
    Set aRange = ActiveDocument.Range

    ' Create the FindText arg, e.g. "(<[Ss]hall>)"
    ' The parentheses create a "group" that we use to build the replacement text
    ' The <> are used to mark the beginning and end of words
    ' to prevent FindText="will" from matching "swill", "goodwill", etc.
    sFindText = "(<" & s & ">)"

    ' Create the ReplaceText arg. "\1" is the found text. Wrap it in the tags.
    sReplaceText = START_TAG & "\1" & END_TAG
    With aRange.Find
        .MatchWildcards = True
        .Execute FindText:=sFindText, ReplaceWith:=sReplaceText, Replace:=wdReplaceAll
    End With
Next I
Set aRange = Nothing
End Sub



Sub RemoveTags()
Dim aRange As Range
Dim sFindText As String
Dim sReplaceText As String

Set aRange = ActiveDocument.Range
sFindText = START_TAG & "(*)" & END_TAG
sReplaceText = "\1"
With aRange.Find
    .MatchWildcards = True
    .Execute FindText:=sFindText, ReplaceWith:=sReplaceText, Replace:=wdReplaceAll
End With
Set aRange = Nothing
End Sub



Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
Dim s As String
intRowCount = 1
Set aRange = ActiveDocument.Range
With aRange.Find
    .MatchWildcards = True
    Do
        .Text = START_TAG & "*" & END_TAG ' the word I am looking for
        .Execute
        If .Found Then
            aRange.Expand Unit:=wdSentence
            s = aRange.Text
            s = Replace(s, START_TAG, "")
            s = Replace(s, END_TAG, "")
            aRange.Collapse wdCollapseEnd
            If objSheet Is Nothing Then
                Set appExcel = CreateObject("Excel.Application")
                 'Change the file path to match the location of your test.xls
                Set objSheet = appExcel.workbooks.Open("C:\Temp\test.xlsx").Sheets("Sheet1")
                intRowCount = 1
            End If
            objSheet.Cells(intRowCount, 1).Formula = s
            intRowCount = intRowCount + 1
        End If
    Loop While .Found
End With
If Not objSheet Is Nothing Then
    appExcel.workbooks(1).Close True
    appExcel.Quit
    Set objSheet = Nothing
    Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub

希望有帮助

单词宏：查找关键字并将句子提取到Excel

2 个答案: