VBA运行时错误1004：复制粘贴区域不匹配，求代码优化方案

问题场景 #

调试VBA代码合并多个工作表的多行多列数据到主工作表时，触发Run-Time Error '1004'，提示can't paste because area not the same。已知问题源于复制粘贴区域范围过大，需优化代码仅选择有效数据范围。

现有代码如下：

Sub OpenXML()
'
'Use this macro to open XML 2003 docs and save them as XLSX and combine them into one XLSX doc
'

Dim wbTemp, wbSave As Workbook
Dim count As Long
Dim xmlFilePath, saveFilePath, fileName As String

Set wbSave = Workbooks.Add
count = 1

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'======>>>>____Update file paths here____<<<<======
xmlFilePath = [withheld]
saveFilePath = [withheld]

file = Dir(xmlFilePath & "*.xml")
fileNameNoExt = Left(file, Len(file) - 4)

'Loop to open the XML file, save a copy as XLSX, AND create a combined file with all data
Do While Len(file) > 0
    'Open each XML file
    Set wbTemp = Workbooks.Open(fileName:=xmlFilePath & file)
    'Save as XLSX
    ActiveWorkbook.SaveAs fileName:=saveFilePath & fileNameNoExt & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    
    'Copy data from each XML into one main XLSX
    wbTemp.Sheets(2).Select
    If count = 1 Then 'take only 1 header row
        Rows("1:1").Select
    Else
        Rows("2:2").Select
    End If
    
    Range(Selection, ActiveCell.End(xlDown)).Select
    Selection.Copy wbSave.Sheets(1).Cells(count, 1)
    wbTemp.Close
    count = wbSave.Sheets(1).UsedRange.Rows.count + 1
    
    'Prep for next file
    file = Dir
    If Len(file) > 0 Then
        fileNameNoExt = Left(file, Len(file) - 4)
    End If
Loop

wbSave.SaveAs fileName:=saveFilePath & "AllSheetsCombined.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wbSave.Close

End Sub

曾尝试以下代码但无效：

Sub SelectRangeDown()
    Range("c1", Range("c1").End(xlDown)).Select
End Sub

错误原因 #

原代码使用Rows("1:1").Select+ActiveCell.End(xlDown)会选中整行至工作表最后一行，复制范围包含所有16384列，而主工作表目标区域列数可能不匹配，触发粘贴区域不一致的错误。同时Select方法低效且易引发对象引用问题。

优化后的代码 #

Sub OpenXML()
' 打开XML 2003文档并另存为XLSX，同时合并所有数据到一个主文件
    Dim wbTemp As Workbook, wbSave As Workbook
    Dim count As Long
    Dim xmlFilePath As String, saveFilePath As String, file As String, fileNameNoExt As String
    
    Set wbSave = Workbooks.Add
    count = 1
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' ======>>>> 在此更新文件路径 <<<<======
    xmlFilePath = [withheld]
    saveFilePath = [withheld]
    
    file = Dir(xmlFilePath & "*.xml")
    
    ' 循环处理每个XML文件
    Do While Len(file) > 0
        fileNameNoExt = Left(file, Len(file) - 4)
        ' 打开XML文件
        Set wbTemp = Workbooks.Open(fileName:=xmlFilePath & file)
        ' 另存为XLSX
        wbTemp.SaveAs fileName:=saveFilePath & fileNameNoExt & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        
        ' 复制有效数据到主工作表
        With wbTemp.Sheets(2)
            Dim lastRow As Long, lastCol As Long
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            
            Dim copyRange As Range
            If count = 1 Then
                ' 第一次复制包含表头
                Set copyRange = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
            Else
                ' 后续复制跳过表头
                Set copyRange = .Range(.Cells(2, 1), .Cells(lastRow, lastCol))
            End If
            
            ' 直接复制到目标区域，无需Select
            copyRange.Copy wbSave.Sheets(1).Cells(count, 1)
        End With
        
        wbTemp.Close SaveChanges:=False
        ' 更新下一次粘贴的起始行
        count = wbSave.Sheets(1).Cells(wbSave.Sheets(1).Rows.Count, "A").End(xlUp).Row + 1
        
        ' 获取下一个文件
        file = Dir
    Loop
    
    wbSave.SaveAs fileName:=saveFilePath & "AllSheetsCombined.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    wbSave.Close
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

关键优化点 #

• 移除所有Select/Selection操作，直接引用对象，避免不必要的对象激活问题，提升代码稳定性和效率
• 通过lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row和lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column精准定位有效数据的边界，仅复制实际有数据的区域
• 修正变量声明：原代码中部分变量未显式声明类型，优化后统一显式声明，避免变体类型引发的潜在问题
• 恢复ScreenUpdating和DisplayAlerts为默认状态，避免影响后续Excel操作

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