Search for a term, copy a block of cells to another worksheet, continue search

I need a function that will search through an array of data on one worksheet named "2010-2012", look for a matching term (say "apple"), then where it finds that term, select and copy all the cells in a range around it (from the row with "apple" down 5 rows and 7 columns), then paste that array to the worksheet named "Sheet1", and iteratively keep doing this until all the data has been reviewed and all matches copied to "Sheet1" without over writing itself.

What I have (that doesn't work) is:

Sub Button1_Click()

    Application.Calculation = xlCalculationManual
    Call GetAppleData(Sheets("2010-2012"), Sheets("2010-2012").Range("B1"), Sheets("Sheet1").Range("d1"), Sheets("Sheet1").Range("a10"), 6, 7)
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Public Sub GetAppleData(sht1 As Worksheet, findrange As Range, count As Range, pasteloc As Range, rowblock As Integer, colblock As Integer)

    Dim x As Integer
    Dim i As Integer
    Dim crude As String
    Dim tempCopyRange As Range
    Dim chkrng As Range
    x = count.Value
        
    i = 0
    Do While i <= x
        
        sht1.Activate
        Set chkrng = Columns(2).Find(what:="apple", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
            
           ' If chkrng.Value = "Crude" Then
          '      MsgBox "found!"
           ' End If
            
        
           Set tempCopyRange = chkrng.Offset(i + rowblock, colblock)
           tempCopyRange.Select
           Selection.Copy
           
           Sheets("Sheet1").Activate
           pasteloc.Select
           tempCopyRange.PasteSpecial Paste:=xlPasteValues
           pasteloc = pasteloc.Offset(rowblock, 0)
        i = i + 1
    Loop
        
End Sub