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

r7knjye2 于 2022-12-01 发布在其他

关注(0)|答案(1)|浏览(140)

有人能帮帮我吗，我有点绝望了
我想搜索数据，然后选择并复制搜索点之前的每一行，但我无法执行此操作我所能做的就是复制包含搜索数据的行

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

excel

来源：https://stackoverflow.com/questions/74615668/how-to-select-and-copy-data-up-to-the-searched-value

1条答案

按热度按时间

sd2nnvve1#

使用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

赞(0）回复(0）举报 2022-12-01

我来回答

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

1条答案

相关问题

热门标签

最新问答