VBA跨工作簿复制多表列数据时出现Run-time error '1004'求助

问题描述 #

需要将一个工作簿中多个工作表的X列（代码中为U列）数据，复制到现有工作簿的B列，要求粘贴到下一个空单元格并遍历所有工作表，但执行代码时弹出1004错误：

Run-time error "1004"
You can't paste here because the Copy and paste area aren't the same size.
Select just one cell in the paste area that's the same size, and try pasting again.

注：源数据带表头，目标工作簿无表头，已尝试调整列宽但问题未解决。

原代码：

Sub CopyColumnUFromDownloadToTurkey()
    Dim downloadWorkbook As Workbook
    Dim turkeyWorkbook As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim sourceRange As Range
    Dim targetRange As Range
   
    ' Set the active workbook as Turkey
    Set turkeyWorkbook = ThisWorkbook
   
    ' Open the download workbook
    Set downloadWorkbook = Workbooks.Open("c:\myfiles\Turkey download.xlsx")
   
    ' Loop through each worksheet in the download workbook
    For Each ws In downloadWorkbook.Worksheets
        ' Find the last row in column A of the Turkey workbook
        lastRow = turkeyWorkbook.Sheets(1).Cells(turkeyWorkbook.Sheets(1).Rows.Count, 1).End(xlUp).Row + 1
       
        ' Set the source range to column U of the current worksheet
        Set sourceRange = ws.Columns("U")
       
        ' Copy the source range to the target range in the Turkey workbook
        sourceRange.Copy
        turkeyWorkbook.Sheets(1).Cells(lastRow, 1).PasteSpecial Paste:=xlPasteValues
    Next ws
   
    ' Close the download workbook
    downloadWorkbook.Close SaveChanges:=False
End Sub

错误原因 #

1. 直接复制整列U，包含了从第1行到Excel最大行数的所有单元格（包括大量空行），当目标工作簿从lastRow开始的剩余行数不足以容纳整列数据时，触发大小不匹配错误。
2. 未跳过源数据的表头，不符合目标无表头的需求。
3. 代码中目标列为A列，但需求是粘贴到B列，存在逻辑偏差。

修正后的代码 #

Sub CopyColumnUFromDownloadToTurkey()
    Dim downloadWorkbook As Workbook
    Dim turkeyWorkbook As Workbook
    Dim ws As Worksheet
    Dim sourceLastRow As Long
    Dim targetLastRow As Long
    Dim sourceRange As Range
   
    ' 设置目标工作簿（当前运行代码的工作簿）
    Set turkeyWorkbook = ThisWorkbook
   
    ' 打开源工作簿
    Set downloadWorkbook = Workbooks.Open("c:\myfiles\Turkey download.xlsx")
   
    ' 遍历源工作簿的每个工作表
    For Each ws In downloadWorkbook.Worksheets
        ' 找到源工作表U列的最后一行数据
        sourceLastRow = ws.Cells(ws.Rows.Count, "U").End(xlUp).Row
        ' 确保有可复制的数据（跳过仅含表头的工作表）
        If sourceLastRow >= 2 Then
            ' 定义源数据范围：U列第2行到最后一行（跳过表头）
            Set sourceRange = ws.Range("U2:U" & sourceLastRow)
           
            ' 找到目标工作簿B列的下一个空行
            targetLastRow = turkeyWorkbook.Sheets(1).Cells(turkeyWorkbook.Sheets(1).Rows.Count, "B").End(xlUp).Row + 1
           
            ' 直接赋值传递数据，替代复制粘贴
            turkeyWorkbook.Sheets(1).Range("B" & targetLastRow).Resize(sourceRange.Rows.Count, 1).Value = sourceRange.Value
        End If
    Next ws
   
    ' 关闭源工作簿，不保存更改
    downloadWorkbook.Close SaveChanges:=False
End Sub

关键修改说明 #

• 仅复制有效数据区域：通过sourceLastRow定位U列最后一行有数据的单元格，只复制从第2行（跳过表头）到该行的范围，避免包含大量空行。
• 跳过源表头：明确从第2行开始复制数据，匹配目标无表头的需求。
• 修正目标列为B列：将原代码中的A列逻辑改为B列，符合需求。
• 直接赋值替代复制粘贴：使用Range.Value直接传递数据，比复制粘贴更高效，同时避免了剪贴板依赖和区域大小匹配问题。
• 增加数据有效性判断：如果源工作表只有表头（无数据行），则跳过该工作表，避免无效操作。

内容的提问来源于stack exchange，提问作者Judda1971