Worksheet Change事件无法复制粘贴数据问题求助

核心问题分析 #

你的代码无法完成复制粘贴的原因主要有3个关键错误：

• 粘贴目标工作表错误：代码中把数据粘贴到了DataSheet（Data表）的A列，而非目标的PastedSheet（Pasted表）
• 复制范围不符需求：你需要复制J:O列，但代码里仅选中了J:K列
• 排序导致目标行偏移：排序操作会改变行的位置，原Target.Row在排序后不再指向输入YES的原行，导致复制错误行的数据

修复后的完整代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Dim lastRow As Long
    Dim DataSheet As Worksheet
    Dim PastedSheet As Worksheet
    Dim destinationRow As Long
    Dim isDataSheetUnprotected As Boolean
    Dim targetRowData As Variant ' 存储原目标行数据，避免排序后偏移
    
    Application.EnableEvents = False
    
    Set DataSheet = ThisWorkbook.Sheets("Data")
    Set PastedSheet = ThisWorkbook.Sheets("Pasted")
    
    ' 明确指定DataSheet的N列作为KeyCells，避免上下文错误
    Set KeyCells = DataSheet.Range("N3:N" & DataSheet.Cells(DataSheet.Rows.Count, "N").End(xlUp).Row)
    
    If Not Application.Intersect(KeyCells, Target) Is Nothing Then
        ' 排序前先记录输入YES的行数据
        If UCase(Target.Value) = "YES" Then
            targetRowData = DataSheet.Range("J" & Target.Row & ":O" & Target.Row).Value
        End If
        
        lastRow = DataSheet.Cells(DataSheet.Rows.Count, "J").End(xlUp).Row
        
        isDataSheetUnprotected = False
        If DataSheet.ProtectContents Then
            DataSheet.Unprotect Password:="Mama, I'm Coming Home"
            isDataSheetUnprotected = True
        End If
        
        ' 执行排序
        DataSheet.Range("J3:O" & lastRow).Sort Key1:=DataSheet.Range("N3:N" & lastRow), _
            Order1:=xlDescending, Header:=xlNo
        
        ' 使用提前存储的数据粘贴，规避排序后的行位置变化
        If Not IsEmpty(targetRowData) Then
            destinationRow = PastedSheet.Cells(PastedSheet.Rows.Count, "A").End(xlUp).Row + 1
            ' 直接赋值替代复制粘贴，更高效且避免剪切板问题
            PastedSheet.Range("A" & destinationRow & ":F" & destinationRow).Value = targetRowData
        End If
        
        If isDataSheetUnprotected Then
            DataSheet.Protect Password:="Mama, I'm Coming Home"
        End If
    End If
    
    Application.EnableEvents = True
End Sub

额外优化说明 #

• 改用直接赋值替代复制粘贴，避免剪切板占用问题，同时提升运行效率
• 提前存储输入YES行的J:O列数据，彻底解决排序后行位置偏移的问题
• 明确指定KeyCells所属工作表，避免当前工作表切换导致的错误
• 若Pasted表也受保护，需在粘贴前添加Unprotect操作（根据实际情况调整）

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