VBA to find sheet and copy rows if cells contain value using reference

[bartoni1]

Hi,
Its been a while since I used VBA so i was hoping someone may be able to help....Ive searched the forum buti cant quite find the solution...
I have 25 sheets in a workbook – each sheet is named after a fruit. Each sheet contains sales information by country in each row. What I’d like to do is create some code to read from a Reference sheet and specify a sheet look up (The Fruit) and then copy rows of data if they match cells as defined in the Reference sheet to a Summary sheet. So in the Reference sheet in Cell A1, I insert the fruit (sheet name so the macro knows which sheet to look at) and then list the specific countries below (A1-A16). In each sheet, the country data is always listed in cell C7:

So for example in the Reference sheet
A1 Apple
A2 Vietnam
A3 Spain
A4 USA

Ive started the code but Im having trouble defining the sheet using the reference to look at and I keep getting debugging errors on the code...
Many Thanks

Sub CopyRows()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Sheets("Apple").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundVal As Range
For Each rng In Sheets("Apple").Range("C2:C" & LastRow)
Set foundVal = Sheets("Reference").Range("A:A").Find(rng, LookIn:=xlValues, lookat:=xlWhole)
If Not foundVal Is Nothing Then
rng.EntireRow.Copy
Sheets("Reference").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Else
rng.EntireRow.Copy
Sheets("Reference").Cells(foundVal.Row, 1).PasteSpecial xlPasteValues

End If
Next rng
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[Fluff]

Is this what you're after

Sub CopyRows()
   Application.ScreenUpdating = False
   Dim LastRow As Long
   Dim Ws As Worksheet
   Dim ary As Variant
   
   With Sheets("Reference")
      ary = Application.Transpose(.Range("A2:A16"))
      Set Ws = Sheets(.Range("A1").Value)
      If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
      Ws.Range("A1:C1").AutoFilter 3, ary, xlFilterValues
      Ws.AutoFilter.Range.Offset(1).EntireRow.Copy
      .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
   End With
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
End Sub