如何选择和复制数据直到搜索到的值？答案

【问题标题】：How to select and copy data up to the searched value?如何选择和复制数据直到搜索到的值？
【发布时间】：2022-11-30 07:17:29
【问题描述】：

谁能帮帮我，我有点绝望了

我想搜索数据然后选择并复制每一行直到搜索点，但是我无法做到这一点我所能做的就是复制包含搜索数据的行

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

【问题讨论】：

过滤后是否只有一行可见？
“直到搜索点的每一行”意味着您希望第 2 行到找到值的行？
@TimWilliams 是的，目前只有一行（带有搜索结果）可见 - 我不知道如何编写代码
@Notus_Panda 是的——在我搜索 2016/Q4 的图片示例中，所以我想将所有内容复制到 ROW5——基本上我总是想复制从第 1 行开始的所有内容，复制的最后一行将是具有搜索值的行
为什么不直接在 A 列中搜索 Obdobi，然后使用简单的匹配（如果您不想使用 excel 公式，则搜索 for 循环），然后使用 Range("A1:A" & foundRow).Entirerow.Copy？如果没有“复制粘贴/复制目标：”，我不太熟悉工作，但对此深表歉意。

标签： excel vba

【解决方案1】：

使用Application.Match()：

Sub Prehled()

    Dim wsSrc As Worksheet, wb As Workbook, wsRpt As Worksheet
    Dim Obdobi As String, wc As String, m
    
    Set wb = ThisWorkbook 'best to be specific...
    Set wsSrc = wb.Worksheets("PomocnyList_3")
    Set wsRpt = wb.Worksheets("K_report")
    
    wsSrc.AutoFilterMode = False
    wc = IIf(en_likematch, "*", "") 'need wildcards?
    
    Obdobi = wb.Worksheets("IN7").Range("Kvartal").Value
    If Len(Obdobi) = 0 Then 'anything to search for?
        MsgBox "No search term entered", vbExclamation
        Exit Sub
    End If
    
    'see if there's a match in ColA
    m = Application.Match(wc & Obdobi & wc, wsSrc.Columns("A"), 0)
    
    If Not IsError(m) Then 'if not an error then we got a match
        With wsSrc.Range("A2:AZ" & m)
            wb.Worksheets("K_report").Range("E25").Resize(.Rows.Count, .Columns.Count).Value = .Value
        End With
    End If
    
End Sub

【讨论】：