Поиск и вставка строки из нескольких слов документов не удается частично (неудачный метод pastespecial класса класса)

Question

У меня есть макрос VBA, который открывает каждый текстовый документ в папке, находит определенную строку в документе и затем вставляет ее в открытую электронную таблицу. Все документы Word имеют один и тот же шаблон и содержат соответствующую строку.

Он работает нормально для первых 4 или 5 документов, а затем я получаю сообщение об ошибке «Не удалось выполнить метод pastespecial класса диапазона». Документ, на котором он отказывается, ни в коем случае не отличается от других, и если я удаляю этот документ, то он выходит из строя на другом. Может кто-нибудь помочь, пожалуйста? Я новичок в 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