时间戳

首页 > 解决方案 > 在其他工作表中搜索多个标题（列），复制数据并粘贴到主文件中

excel - 在其他工作表中搜索多个标题（列），复制数据并粘贴到主文件中

问题描述

我需要一个按钮的 VBA 代码，当单击该按钮浏览其他 Excel 文件时，在其中搜索名为“Farmer History”的特定工作表。在此工作表中，它查找 A1 完整行并搜索标题“裁剪区域”并将此列数据复制到名为“Berkund”的工作表中最后一个单元格下方的 F 列的主文件（嵌入按钮的位置）。

其他 2 列也一样，即

在同一工作表“Farmer History”的第一行中查找“Target Qty”，并粘贴到主文件工作表“Berkhund”的 R 列中最后一个单元格下方使用

在同一工作表“农民历史”的第一行中查找“Commulative Sold”，并粘贴到最后一个单元格下方 S 列的主文件工作表“Berkhund”中。我尝试过的代码如下所示，但它无法浏览文件、搜索和粘贴回主文件：

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

结束子

图片

标签： excelvba

解决方案

定义一个包含 3 个搜索词和目标列的数组，并在循环中使用它们。

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

推荐阅读