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循环中，所以它会ve在第一个复制实例上关闭，而不是完成循环，所以我将其移到末尾（除非有此意图，但无论如何我都将其移开，这样我可以告诉工作簿在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块中的工作簿将不符合范围。

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

2 个答案: