Search multiple headings(Columns) in other sheet, copy data and paste in main file - excel

Question

I need a VBA code for a button which when clicked browse for other excel file, search for specific sheet named “Farmer History” in it. In this sheet it looks for A1 complete row and search heading “Crop Area” and copy this column data to main file(where button embedded) in sheet named “Berkhund” at F Column below last cell is used.
The same to be done for other 2 columns too i.e
Looks for “Target Qty” in first row at same sheet “Farmer History” and paste in main file sheet “Berkhund” at R Column below last cell is used
Looks for “Commulative Sold” in first row at same sheet “Farmer History” and paste in main file sheet “Berkhund” at S Column below last cell is used.Code which i tried is given below but it cannot BROWSE for file, search and paste back in main file:
Sub copycroparea()
Dim sh As Worksheet, fn As Range
Set sh = Sheets("Farmer History")
Set fn = sh.Rows(1).Find(" Crop Area", , xlValues, xlWhole)
If Not fn Is Nothing Then
fn.Offset(1).Resize(sh.Cells(Rows.Count, fn.Column).End(xlUp).Row, 1).Copy
Sheets("Berkhund").Range("F13")
Else
MsgBox "Crop area Not Found!"
Exit Sub
End If
End Sub

Answer 1

Define an array with the 3 search terms and target coumns and use them in a loop.
Option Explicit
Sub copycroparea()
Const RESULT = "Sheet2" '"Berkhund"
Const SOURCE = "Farmer History"
Dim term(3) As Variant
term(1) = Array("Crop Area", 6) 'F
term(2) = Array("Target Qty", 18) 'R
term(3) = Array("Commulative Sold", 19) 'S
Dim wb As Workbook, ws As Worksheet
Dim wbSearch As Workbook, wsSearch As Worksheet
Dim iTargetRow As Long, iLastRow As Long, sFilename As String
' search for file
sFilename = Application.GetOpenFilename("Excel Files (*.xlsx; *.xlsm),*.xlsx;*.xlsm")
If Len(sFilename) = 0 Or sFilename = "False" Then
MsgBox "No file selected ", vbCritical
End If
'Debug.Print sFilename
Set wb = ThisWorkbook
Set ws = wb.Sheets(RESULT)
Set wbSearch = Workbooks.Open(sFilename, False, True) ' no links update, read only
Set wsSearch = wbSearch.Sheets(SOURCE)
Dim i As Integer, sTerm As String, iCol As Integer, msg As String
Dim rng As Range, rngTarget As Range
For i = 1 To UBound(term)
sTerm = term(i)(0)
iCol = term(i)(1)
'Debug.Print i, sTerm, iCol
Set rng = wsSearch.Rows(1).Find(sTerm, , xlValues, xlPart)
If Not rng Is Nothing Then
' Destination for copy on main file
Set rngTarget = ws.Cells(Rows.Count, iCol).End(xlUp).Offset(1, 0)
' find extent of data
iLastRow = wsSearch.Cells(Rows.Count, rng.Column).End(xlUp).Row
'Debug.Print rngTarget.Address, iLastRow
' copy
rng.Offset(1, 0).Resize(iLastRow, 1).Copy rngTarget
msg = msg & sTerm & " found at " & rng.Address & vbCr
Else
msg = msg & sTerm & "not found" & vbCr
End If
Next
wbSearch.Close False
MsgBox msg, vbInformation
End Sub