Runtime error '1004'：Application对象Intersect方法调用失败求助

错误根源 #

当修改的单元格不在Sheet2时，Target属于其他工作表，和Sheet2.UsedRange跨表调用Intersect就会触发1004错误——因为Intersect要求两个区域必须在同一个工作表内。此外，未禁用事件会导致复制操作再次触发SheetChange，可能引发额外问题。

修正后的代码 #

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    Dim lastRow As Long
    Dim checkRange As Range

    ' 指定源工作表和目标工作表
    Set sourceSheet = ThisWorkbook.Sheets("Sheet2")
    Set destinationSheet = ThisWorkbook.Sheets("Sheet5")

    ' 仅处理源工作表的修改，非源表直接退出
    If Not Sh Is sourceSheet Then Exit Sub

    ' 处理源表无数据的情况，避免UsedRange为空导致的错误
    If sourceSheet.UsedRange Is Nothing Then Exit Sub
    Set checkRange = sourceSheet.UsedRange

    ' 检查修改区域是否在目标范围内
    If Not Intersect(Target, checkRange) Is Nothing Then
        ' 禁用事件，防止复制操作触发二次SheetChange
        Application.EnableEvents = False

        ' 找到目标表最后一行，处理空表情况
        lastRow = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row
        lastRow = IIf(lastRow = 1 And destinationSheet.Cells(1, "A") = "", 1, lastRow + 1)

        ' 复制整行到目标表
        sourceSheet.Rows(Target.Row).Copy destinationSheet.Rows(lastRow)

        ' 可选：清空源表该行内容
        ' sourceSheet.Rows(Target.Row).ClearContents

        ' 恢复事件
        Application.EnableEvents = True
    End If

ErrorHandler:
    ' 确保事件始终恢复，避免后续事件失效
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "错误：" & Err.Description, vbExclamation
End Sub

关键修正点 #

• 增加工作表判断：先确认触发事件的是Sheet2，非目标表直接退出，彻底避免跨表调用Intersect的问题。
• 处理空表情况：判断UsedRange是否为空，防止checkRange无效引发报错。
• 禁用/恢复事件：复制操作会触发SheetChange事件，禁用事件可以避免循环触发导致的错误；错误处理段确保即使出错，事件也能恢复，避免后续功能失效。
• 优化最后一行判断：处理目标表为空的情况，避免从第2行开始出现空行。

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