Поиск нескольких заголовков (столбцов) на другом листе, копирование данных и вставка в основной файл

Question

Мне нужен код VBA для кнопки, при нажатии которой ищите другой файл Excel, найдите в нем указанный лист c с именем «История фермера». На этом листе он ищет строку А1 и заголовок поиска «Область обрезки» и копирует данные этого столбца в основной файл (куда встроена кнопка) на листе с именем «Berkhund» в столбце F под последней ячейкой.

То же самое должно быть сделано и для других 2 столбцов, т.е.

Ищет «Целевое количество» в первой строке на том же листе «История фермера» и вставляет в основной файл «Берхунд» в столбце R под последней ячейкой.

Ищет «Коммутируемая продажа» в первом ряду на том же листе «История фермера» и вставляет в основной файл «Берхунд» в столбце S под последней ячейкой. Используемый код приведен ниже, но не может ПОИСК для файла, поиска и вставки обратно в основной файл:

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

Определите массив с 3 поисковыми терминами и целевыми символами и используйте их в al oop.

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