Один из способов решения этой проблемы:
(1) Используйте поиск / замену Word, чтобы обернуть слова, представляющие интерес (должны, будут), в теги, например, будут, будут.и может быть чем угодно, чего вы не ожидаете в исходном документе 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
Надеюсь, что поможет