如何修改VBA宏实现指定单元格值的跨工作表搜索与结果粘贴

原代码的核心问题 #

• 变量不匹配：定义了SearchCol但循环时用了未声明的StatusCol，运行会直接报错
• 粘贴位置逻辑冗余：每次循环都重复判断C4是否为空，可能导致重复查找或覆盖已有内容
• 单元格选取错误：Offset(1,2)是向下偏移1行、向右偏移2列，完全不符合“匹配单元格所在行的该单元格及后续2个单元格”的需求
• 未处理空关键词：若C3为空，会搜索所有空单元格，属于无效操作

修正后的代码 #

Sub SearchForWord()
    Dim searchRange As Range
    Dim targetCell As Range
    Dim pasteStart As Range
    Dim searchKey As String
    
    ' 获取搜索关键词并去除前后空格
    searchKey = Trim(Sheet1.Range("C3").Value)
    
    ' 关键词为空时直接提示退出
    If searchKey = "" Then
        MsgBox "请输入搜索关键词！", vbExclamation
        Exit Sub
    End If
    
    ' 定义要搜索的区域：Sheet2的D7:D100
    Set searchRange = Sheet2.Range("D7:D100")
    
    ' 确定Sheet1的粘贴起始位置
    If Sheet1.Range("C4").Value = "" Then
        Set pasteStart = Sheet1.Range("C4")
    Else
        Set pasteStart = Sheet1.Range("C4").End(xlDown).Offset(1, 0)
    End If
    
    ' 遍历搜索区域的每个单元格
    For Each targetCell In searchRange
        ' 匹配关键词（不区分大小写，需严格区分则删除UCase）
        If UCase(targetCell.Value) = UCase(searchKey) Then
            ' 复制当前单元格及右侧2个单元格（共3列）到粘贴位置
            targetCell.Resize(1, 3).Copy pasteStart
            ' 更新粘贴位置到下一行
            Set pasteStart = pasteStart.Offset(1, 0)
        End If
    Next targetCell
End Sub

关键逻辑说明 #

• 空关键词拦截：避免无效搜索，弹出提示引导用户输入内容
• 粘贴位置初始化：仅在循环前确定一次起始位置，后续每次粘贴后自动下移一行，避免重复判断
• 正确选取目标单元格：Resize(1,3)直接选中匹配单元格及右侧2个单元格，精准满足需求
• 不区分大小写匹配：用UCase统一转换为大写，提升搜索的友好度（如需严格区分大小写，删除UCase即可）

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