复制粘贴宏触发Application-defined or object-defined error求助

错误根源分析 #

你的宏出现Application-defined or object-defined error主要有以下几个原因：

• 目标粘贴区域越界：当Sheet2的A列已有数据时，Sheet2.Range("A1").End(xlDown)会定位到A列最后一个非空单元格，若该单元格是工作表最后一行（如A1048576），Offset(1,0)会超出工作表范围，触发错误。
• 无效的单元格范围引用：ECR.End(xlToLeft)和ECR.End(xlToRight)在某些场景下会返回意外结果（比如ECR所在行的首尾是空白单元格，或整行只有H列有数据），导致生成的Range对象无效。
• 遍历冗余单元格：循环遍历H2:H1000的所有单元格，包括大量空白单元格，既降低效率也可能引发不必要的判断逻辑问题。

修复后的代码 #

Option Explicit

Sub CopyECR()
    Dim ECRCol As Range
    Dim ECR As Range
    Dim PasteCell As Range
    Dim targetRow As Long
    
    ' 只遍历H列中已使用的非空单元格，避免冗余循环
    Set ECRCol = Sheet1.Range("H2", Sheet1.Range("H" & Sheet1.Rows.Count).End(xlUp))
    
    For Each ECR In ECRCol
        ' 确定Sheet2的目标粘贴行，避免越界
        targetRow = IIf(Sheet2.Range("A2").Value = "", 2, Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Row + 1)
        Set PasteCell = Sheet2.Range("A" & targetRow)
        
        ' 仅当ECR单元格值为"Yes"时执行复制
        If StrComp(ECR.Value, "Yes", vbTextCompare) = 0 Then
            ' 复制ECR所在行的A到H列（可根据实际需求调整列范围）
            Sheet1.Range(Sheet1.Cells(ECR.Row, 1), Sheet1.Cells(ECR.Row, ECR.Column)).Copy PasteCell
            ' 如果需要复制整行已使用区域，替换为下面一行：
            ' ECR.EntireRow.Copy PasteCell
        End If
    Next ECR
End Sub

关键优化点说明 #

• 缩小遍历范围：改为遍历H列从H2到最后一个非空单元格，避免处理大量空白行。
• 安全定位粘贴行：从工作表底部向上找最后一个非空单元格，再偏移一行，彻底避免越界问题。
• 明确复制范围：直接指定复制A到H列（或用EntireRow复制整行），替代不稳定的End(xlToLeft/xlToRight)。
• 大小写不敏感判断：用StrComp函数进行文本比较，避免因大小写差异导致判断失效。

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