Различные ошибки времени выполнения с макросом копирования / вставки

Question

Я собрал макрос копирования / вставки, который будет копировать выбранные ячейки из серии книг по указанному пути.Код скопирует все строки, содержащие определенные значения (слова) из всех рабочих книг в пути, и вставит их в любую рабочую книгу, открытую в следующей пустой строке.

В настоящее время код, кажется, делает все правильно, кроме вставки части.Я не уверен, почему, но я получаю «Ошибка времени выполнения» 2147221080 (800401a8) «Ошибка автоматизации» Когда я запускаю код, он выполняет одно копирование и вставку, а затем, кажется, попадает в бесконечностьцикл, который должен быть разорван.Если я попытаюсь запустить код снова, появится ошибка времени выполнения. Строка ошибки прокомментирована в коде.

Option Explicit
Sub CopyRange()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim i As Integer
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim strExtension As String
    Dim LastRow As Long
    Dim a As Integer

    Const strPath As String = "H:\My Documents\FinalCopyPaste\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource.Sheets("Sheet1")
            a = .Cells(Rows.Count, 1).End(xlUp).Row
            For i = 1 To a
                If .Cells(i, 1).Value = "PIZZA" And .Cells(i, 4).Value = "WATER" And .Cells(i, 8).Value = "9/26/2019" Then
                    LastRow = wkbDest.Worksheets("Zone").Cells(Rows.Count, "A").End(xlUp).Offset(1).Row
                    'Error occurs in line below
                    .Worksheets("Sheet1").Rows(i).Copy wkbDest.Worksheets("Zone").Range("A" & LastRow) 'Error occurring at this line
                    .Close savechanges:=False
                End If
            Next
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Answer 1

Ваши строки

With wkbSource
    a = .Cells(Rows.Count, 1).End(xlUp).Row

просто говорят "Ячейки в рабочей книге"

вам также нужно указать рабочий лист, например,

With wkbSource.sheets(1)
    a = .Cells(.Rows.Count, 1).End(xlUp).Row

Вам также необходимоукажите рабочий лист в Rows.count

, и, наконец, событие закрытия вашей книги больше не будет работать в With, поскольку With теперь ссылается на рабочий лист PLUS, он был внутри цикла Forво всяком случае, чтобы он закрылся на первом экземпляре копирования, вместо завершения цикла, поэтому я переместил его в конец (если это не было запланировано, но я все равно переместил его, чтобы я мог сказать книге закрыться за пределами предложения With workbook.worksheet

Весь исправленный код здесь:

Sub CopyRange()

    Dim i As Integer
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim strExtension As String
    Dim LastRow As Long
    Dim a As Integer

    Const strPath As String = "H:\My Documents\FinalCopyPaste\"
    ChDir strPath
    strExtension = Dir(strPath & "*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource.Sheets(1) ' I'm telling it to use the sourceworkbook, sheet 1
            a = .Cells(.Rows.Count, 1).End(xlUp).Row
            For i = 1 To a
                If .Cells(i, 1).Value = "PIZZA" And .Cells(i, 4).Value = "WATER" And .Cells(i, 8).Value = "9/26/2019" Then
                    ' You also needed to specify the book and sheet here
                    LastRow = wkbDest.Worksheets("Zone").Cells(wkbDest.Worksheets("Zone").Rows.Count, "A").End(xlUp).Offset(1).Row
                    Worksheets("Sheet1").Rows(i).Copy wkbDest.Worksheets("Zone").Range("A" & LastRow)
                End If
            Next
        End With
        'moved the close to outside the For loop and made sure it's closing wkbSource
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop

End Sub

Answer 2

Поставьте точку . перед первой командой: .Worksheets("Sheet1").Rows(i).Copy, иначе рабочая книга в вашем блоке With не определит диапазон.