Excel VBA实现自动复制指定值对应行数据至新工作表

我在Excel的一个工作表里存了部分数据，需要从某一列找特定值，把对应行的数据复制到新工作表；要是这列有多个匹配值，就得把所有对应行都复制。比如我要找值409539，把所有匹配行的内容都粘贴到名为"Search"的工作表里。现在写了VBA代码但运行报错，代码如下：

For Each c In rngSearch
    If c.Value = SearchRange Then
        For Each K In ActiveWorkbook.Sheets("Search").Range("1:10")
            If K.Value = "" Then
                ActiveWorkbook.Sheets("Search").K.Value = c.Value
            End If
        Next K
        Replace = c.Offset(0, 5).Value
        ActiveWorkbook.Sheets("Search").Range("B2").Value = Replace
    End If
Next c

原代码的问题 #

• 判断条件错误：If c.Value = SearchRange逻辑混乱，应该拿单元格值和目标查找值（比如409539）对比，而非和搜索范围对象比较。
• 单元格写入语法错误：ActiveWorkbook.Sheets("Search").K.Value是无效写法，K已经是该工作表的Range对象，直接写K.Value = c.Value即可。
• 业务逻辑混乱：内层循环遍历1-10行所有单元格找空值写入，完全不符合"复制整行"的需求；而且每次匹配都会覆盖B2单元格的值，多个匹配时只会保留最后一个结果。

修复后的代码 #

Sub CopyMatchingRows()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim rngSearch As Range
    Dim searchValue As Variant
    Dim lastRow As Long
    Dim targetRow As Long
    Dim c As Range
    
    ' 替换成你的源工作表名称
    Set wsSource = ThisWorkbook.Worksheets("源工作表")
    Set wsTarget = ThisWorkbook.Worksheets("Search")
    ' 要查找的目标值
    searchValue = 409539
    
    ' 假设查找列是A列，可根据实际修改列标
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    ' 从A2开始（跳过表头），无表头则改成A1
    Set rngSearch = wsSource.Range("A2:A" & lastRow)
    
    ' 目标表从第二行开始写入（假设第一行是表头）
    targetRow = 2
    
    For Each c In rngSearch
        If c.Value = searchValue Then
            ' 复制整行到目标工作表
            c.EntireRow.Copy wsTarget.Cells(targetRow, 1)
            targetRow = targetRow + 1 ' 写完一行，目标行下移
        End If
    Next c
    
    ' 清除剪贴板，避免残留复制状态
    Application.CutCopyMode = False
End Sub

代码说明 #

• 明确指定源表和目标表，避免依赖当前激活的工作表，减少不确定性错误
• 直接拿单元格值和目标查找值对比，逻辑清晰易懂
• 用EntireRow.Copy一次性复制整行，无需逐个单元格处理，效率更高
• 用targetRow变量跟踪目标表的写入位置，多个匹配行可依次向下写入，不会覆盖已有内容

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