如何选择并复制搜索值所在行及之前的所有数据？

需求说明 #

根据指定值搜索数据后，复制从起始行（含表头）到该搜索值所在行的所有行数据，但当前编写的VBA代码仅能复制包含搜索值的单行数据。

原VBA代码 #

Sub Prehled()

    Dim datarng As Range
    Dim lr As Long
    Dim wb As Workbook
    Dim VysledekHledani As Long
    Dim Obdobi As String
    
    Application.ScreenUpdating = False
    
    ThisWorkbook.Activate
    Range("A1").Select
    
    Obdobi = Sheets("IN7").Range("Kvartal").Value
    
    Sheets("PomocnyList_3").Select
    Sheets("PomocnyList_3").AutoFilterMode = False
    
    lr = Sheets("PomocnyList_3").Range("A" & Rows.Count).End(xlUp).Row
    
    Set datarng = ActiveSheet.Range("$A$1:$AZ$" & lr)
    
    If Obdobi <> "" Then
        If en_likematch = True Then
            datarng.AutoFilter Field:=1, Criteria1:="=*" & Obdobi & "*", Operator:=xlAnd
        Else
            datarng.AutoFilter Field:=1, Criteria1:="=" & Obdobi
        End If
    End If
    
    VysledekHledani = Range("A1:A" & lr).SpecialCells(xlCellTypeVisible).Count
    
    If VysledekHledani > 1 Then
        
        Sheets("K_report").Select
        Cells.Range("B25").Value = "Test?"
         
        Application.CutCopyMode = False
        
    End If
    
    If VysledekHledani > 1 Then
        Sheets("PomocnyList_3").Select
        Range("A2:AZ99").SpecialCells(xlCellTypeVisible).Select
        ActiveSheet.AutoFilterMode = False
        Selection.Copy
     
        Sheets("K_report").Select
        
        Range("E25").PasteSpecial Paste:=xlPasteValues
              
        Application.CutCopyMode = False
        
    End If
    
    Application.ScreenUpdating = True
    
End Sub

问题分析 #

1. 当前代码采用AutoFilter筛选匹配行的逻辑，仅复制筛选后的可见行，不符合“复制从起始行到搜索值所在行全部行”的需求；
2. 大量使用Select和ActiveSheet，不仅降低代码执行效率，还容易因工作表切换出现错误；
3. 硬编码的Range("A2:AZ99")无法适配动态变化的数据行数，存在数据遗漏或超出范围的风险。

修改后的VBA代码 #

以下代码实现定位到第一个匹配搜索值的行，复制从表头到该行的所有数据，并粘贴到目标区域：

Sub Prehled()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim searchValue As String
    Dim foundRow As Range
    Dim copyRange As Range
    Dim lastRow As Long
    
    ' 关闭屏幕更新提升效率
    Application.ScreenUpdating = False
    
    ' 直接引用工作表，避免使用Select/Activate
    Set wsSource = ThisWorkbook.Sheets("PomocnyList_3")
    Set wsTarget = ThisWorkbook.Sheets("K_report")
    searchValue = ThisWorkbook.Sheets("IN7").Range("Kvartal").Value
    
    ' 清空之前的筛选
    wsSource.AutoFilterMode = False
    
    If searchValue <> "" Then
        ' 查找第一个匹配值的位置（列A）
        If en_likematch = True Then
            Set foundRow = wsSource.Range("A:A").Find(What:="*" & searchValue & "*", LookIn:=xlValues, LookAt:=xlWhole)
        Else
            Set foundRow = wsSource.Range("A:A").Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole)
        End If
        
        ' 如果找到匹配行
        If Not foundRow Is Nothing Then
            ' 定义复制范围：从A1到AZ列的匹配行
            lastRow = foundRow.Row
            Set copyRange = wsSource.Range("A1:AZ" & lastRow)
            
            ' 复制值到目标区域
            copyRange.Copy
            wsTarget.Range("E25").PasteSpecial Paste:=xlPasteValues
            
            ' 测试标记（可保留或删除）
            wsTarget.Range("B25").Value = "复制完成"
        Else
            ' 未找到匹配时的提示
            wsTarget.Range("B25").Value = "未找到匹配数据"
        End If
    Else
        ' 搜索值为空时的提示
        wsTarget.Range("B25").Value = "请输入搜索值"
    End If
    
    ' 清理剪贴板
    Application.CutCopyMode = False
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
End Sub

代码说明 #

1. 直接引用工作表对象，避免Select/Activate操作，提升代码稳定性；
2. 使用Find方法定位第一个匹配搜索值的行，精准获取需要复制的范围；
3. 动态定义复制区域，适配不同的数据行数；
4. 增加了未找到匹配、搜索值为空的提示逻辑，提升代码的健壮性。

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