How to select and copy data up to the searched value? - excel

Question

Can anyone please help me out, Im getting a little bit desperate
I want to search for data and then select and copy every-row up to the searched point, however I wasnt able to do this all I can do is to copy the row that includes the searched data
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

Answer 1

Using 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