excel - 复制/粘贴宏的各种运行时错误

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 现在引用了一个工作表，而且它位于 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