Excel VBA运行时1004 Ms Excel无法粘贴数据

我使用此宏自动将一系列单元格从一个Excel文件复制并粘贴到另一个Excel文件。它似乎可以处理8-10个文件。但我必须处理大约49个文件，这就是我面临问题的时候。我收到运行时错误1004:Ms Excel无法粘贴数据

以下是调试器带我去的代码行：

ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 1), Cells(emptyRow, 23))

下面是我使用的所有代码：

Sub AllFilesProject1()
Dim folderPath As String
Dim filename As String
Dim wb As Workbook

folderPath = "C:\Users\enchevay\Desktop\automation\WeeklyReports\"

If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"

filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
  Application.ScreenUpdating = False


   'copy & paste range of information
   Set wb = Workbooks.Open(folderPath & filename)
   wb.Worksheets("Report Figures (hidden)").Visible = True
   Worksheets("Report Figures (hidden)").Range("A3:W3").Copy
   emptyRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
   Application.DisplayAlerts = False
   ActiveWorkbook.Close
   ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(emptyRow, 1), Cells(emptyRow, 23))

    Application.ScreenUpdating = True
    filename = Dir
Loop

Sub-AllFilesProject1（）
将folderPath设置为字符串
将文件名设置为字符串
将wb设置为工作簿
folderPath=“C:\Users\enchevay\Desktop\automation\WeeklyReports\”
如果正确（folderPath，1）“\”则folderPath=folderPath+“\”
filename=Dir（folderPath&“*.xlsx”）
文件名“”时执行此操作
Application.ScreenUpdating=False
'复制并粘贴信息范围
设置wb=Workbooks.Open（文件夹路径和文件名）
wb.工作表（“报告图（隐藏）”）。可见=真
工作表（“报表图形（隐藏）”）。范围（“A3:W3”）。副本
emptyRow=Sheet1.单元格（Rows.Count，1）.结束（xlUp）.偏移量（1，0）.行
Application.DisplayAlerts=False
活动工作簿。关闭
ActiveSheet.Paste目标：=工作表（“Sheet1”）。范围（单元格（emptyRow，1），单元格（emptyRow，23））
Application.ScreenUpdating=True
filename=Dir
环

'Application.ScreenUpdating=True 端接头

我不明白为什么有时它会在18号文件上崩溃，有时在29号文件上崩溃？另外，当我用F8运行它时，代码似乎工作得很好。 你能帮我解决那个问题吗

---

谢谢

您的代码似乎有一些地方出了问题。我先走一步，帮你把它清理干净。它还应该纠正错误

试试这个

Sub AllFilesProject1()
    Dim folderPath As String
    Dim filename As String
    Dim wb1 As Workbook, wb2 As Workbook
    Set wb1 = ThisWorkbook

    folderPath = "C:\Users\enchevay\Desktop\automation\WeeklyReports\"

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"

    filename = Dir(folderPath & "*.xlsx")
    Do While filename <> ""
        Application.ScreenUpdating = False

        'copy & paste range of information
        Set wb2 = Workbooks.Open(folderPath & filename)
        wb2.Worksheets("Report Figures (hidden)").Visible = True
        emptyrow = wb1.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        wb2.Worksheets("Report Figures (hidden)").Range("A3:W3").Copy _
            Destination:=wb1.Worksheets("Sheet1").Range(Cells(emptyrow, 1), Cells(emptyrow, 23))

        Application.DisplayAlerts = False
        wb2.Close
        Application.DisplayAlerts = True

        Application.ScreenUpdating = True
        filename = Dir
    Loop

End Sub

Sub-AllFilesProject1（）
将folderPath设置为字符串
将文件名设置为字符串
将wb1设置为工作簿，将wb2设置为工作簿
设置wb1=ThisWorkbook
folderPath=“C:\Users\enchevay\Desktop\automation\WeeklyReports\”
如果正确（folderPath，1）“\”则folderPath=folderPath+“\”
filename=Dir（folderPath&“*.xlsx”）
文件名“”时执行此操作
Application.ScreenUpdating=False
'复制并粘贴信息范围
Set wb2=Workbooks.Open（文件夹路径和文件名）
wb2.工作表（“报告图（隐藏）”）。可见=真
emptyrow=wb1.工作表（“Sheet1”）.单元格（Rows.Count，1）.结束（xlUp）.偏移量（1，0）.行
wb2.工作表（“报告图（隐藏）”）。范围（“A3:W3”）。副本_
目的地：=wb1.工作表（“表1”）.范围（单元格（清空箭头，1），单元格（清空箭头，23））
Application.DisplayAlerts=False
wb2.关闭
Application.DisplayAlerts=True
Application.ScreenUpdating=True
filename=Dir
环
端接头

只是猜测，但当您关闭一个相对较大的工作簿时，可能正在清除剪贴板。不要在

ActiveWorkbook之后粘贴。请先关闭
尝试粘贴--您必须在顶部创建一个变量来保存
ActiveSheet
（例如
dim origWS as WorkSheet:set origWS=activeworksheet
），然后origWS.Paste…emptyRow的值是多少？发生了什么错误？我试过了，但我得到了一个运行时错误1004它与那行wb2有关。工作表（“报表图形（隐藏）”）。范围（“A3:W3”）。复制目标：=wb1。工作表（“Sheet1”）。范围（单元格（emptyRow，1），单元格（emptyRow，23））工作表名称或未设置的工作簿对象中可能有错误。确保你的工作表拼写正确，并且在复印之前你的工作手册已经准备好了。