从多个单词文档中查找和粘贴字符串中途失败(范围类的特殊粘贴方法失败)

Question

我有一个VBA宏，它可以打开文件夹中的每个word文档，并在文档中找到某个字符串，然后将其粘贴到打开的电子表格中。所有 Word 文档都属于同一模板，并且包含有问题的字符串。

它对于前 4 或 5 个文档运行良好，然后我收到错误"范围类的粘贴特殊方法失败"。它失败的文档与其他文档没有任何不同，如果我删除此文档，那么它在另一个文档上失败。谁能帮忙？我是 VBA 的新手，所以我的代码很可能是垃圾。 以下是完整的代码：

Sub readForml()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim i As Integer
Dim myWkSht As Worksheet
wdApp.Visible = False
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
myExtension = "*.docx*"
Set myWkSht = ActiveSheet
myPath = "path_to_folder"
myFile = Dir(myPath & myExtension)
'set i to be furst blank row
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set myDoc = wdApp.Documents.Open(Filename:=myPath & myFile)
DoEvents

With myDoc.Content
.Find.ClearFormatting
With .Find
.Text = "number[0-9]{4}"
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = True
.Execute
End With
.Copy
myWkSht.Range("A" & i).PasteSpecial xlPasteValues

End With
myDoc.Close SaveChanges:=False
i = i + 1
'Get next file name
myFile = Dir()
Loop
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

提前感谢">

Answer 1

此代码存在许多问题，可能会导致问题。我不确定任何(或组合(是原因，但让我们看看......

1. 在 VBA 中，不应在同一行上声明和实例化对象。这在 VB.NET 中是可以的，但不是 VBA。因此，在一行中声明wdApp，但在另一行中声明Set wdApp = New Word.Application。
2. 为查找使用特定的Range对象。目前，代码一方面告诉Word复制整个文档，但"找到"是搜索词 - 这对VBA来说是令人困惑的。
3. 尝试将Set myDoc = Nothing放在Loop语句之前，以便在将下一个文档分配给它之前显式释放myDoc。
4. 通常，最好测试是否确实找到了搜索到的术语。如果发生这种情况，不确定您希望发生什么，但进行测试是件好事。

另请注意，注释不准确，代码不是循环 Excel 文件而是循环 Word 文件。这不是导致问题的原因，但应更正以避免混淆。

Sub readForml()
Dim wdApp As Word.Application
Dim myDoc As Word.Document
Dim wdRange as Word.Range
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim i As Integer, bFound as Boolean
Dim myWkSht As Worksheet
Set wdApp = New Word.Application
wdApp.Visible = False
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
myExtension = "*.docx*"
Set myWkSht = ActiveSheet
myPath = "path_to_folder"
myFile = Dir(myPath & myExtension)
'set i to be first blank row
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set myDoc = wdApp.Documents.Open(Filename:=myPath & myFile)
DoEvents
Set wdRange = myDoc.Content
With wdRange   
.Find.ClearFormatting
With .Find
.Text = "number[0-9]{4}"
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = True
bFound = .Execute
End With
If bFound Then
.Copy
myWkSht.Range("A" & i).PasteSpecial xlPasteValues
Else
MsgBox "Search term not found"
End If
End With
myDoc.Close SaveChanges:=False
Set myDoc = Nothing
i = i + 1
'Get next file name
myFile = Dir()
Loop
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub