Excel VBA问题：复制指定条件单元格，解决重复粘贴与无匹配报错

问题原因分析 #

1. 重复粘贴问题：原代码仅把Set IssuedCell = Cell放在If判断内，后续复制、粘贴逻辑在判断块外，导致无论当前单元格是否为"Issued"，都会执行粘贴——如果找到过匹配单元格，后续循环会一直重复复制最后一个匹配项；如果没找到，还会触发对象引用错误。
2. 无匹配时报错问题：当没有单元格值为"Issued"时，IssuedCell始终处于未赋值的Nothing状态，执行IssuedCell.Offset操作时会直接报错。

修正后的代码 #

Option Explicit

Sub IssuedPolicies()
    Dim SearchRng As Range
    Dim Cell As Range
    Dim IssuedRange As Range
    Dim Target As Range
    Dim hasIssued As Boolean
    
    ' 初始化搜索范围，明确指定工作表避免歧义
    Set SearchRng = ThisWorkbook.ActiveSheet.Range("L28:L42")
    hasIssued = False
    
    For Each Cell In SearchRng
        ' 仅在匹配"Issued"时执行复制逻辑
        If Cell.Value = "Issued" Then
            hasIssued = True
            ' 定位当前行要复制的I:K列区域
            Set IssuedRange = Range(Cell.Offset(0, -3), Cell.Offset(0, -1))
            ' 定位AP列的首个空行
            Set Target = ThisWorkbook.ActiveSheet.Range("AP" & Rows.Count).End(xlUp).Offset(1, 0)
            ' 直接赋值替代复制粘贴，避免剪贴板占用且效率更高
            Target.Resize(1, 3).Value = IssuedRange.Value
        End If
    Next Cell
    
    ' 无匹配项时提示用户，避免报错
    If Not hasIssued Then
        MsgBox "未找到值为'Issued'的单元格", vbInformation
    End If
End Sub

关键修改说明 #

• 逻辑块包裹：将复制、赋值逻辑完全放入If判断块内，确保仅匹配到"Issued"时才执行操作，彻底解决重复粘贴问题。
• 无匹配处理：新增hasIssued标记，遍历结束后根据标记判断是否有匹配项，无匹配时弹出提示而非报错。
• 效率优化：用直接赋值替代复制粘贴操作，避免剪贴板占用，同时提升代码运行效率。
• 变量规范：添加Option Explicit强制变量声明，避免未声明变量的潜在问题；明确指定操作工作表，防止跨工作表操作的意外错误。

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