搜索多个Excel文件中的文本值，并将单元格值复制到主文件

Question

我正在使用代码从多个单元格中的多个excel文件中提取数据，并将提取的值粘贴到主文件中。例如，名称在单元格A9中，电话在单元格B6等中。

但现在收到的原始数据发生了变化，并且动态更改了单元格位置。我能找到这些值的唯一相同之处是通过文本搜索，如果我必须找到“名称”，我需要代码首先找到文本“名称”并复制找到的单元格下面的值。也就是说如果在单元格“A10”中找到“名称”，那么我需要代码来复制值“A11”，同样地找到文本“Phone”，如果在单元格“B23”中找到文本，则复制“B24”的值，依此类推。

Sub Consolidate()

Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim RngDest As Range



Set destsheet = ThisWorkbook.Worksheets("Extractdata")
Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp) _
                   .Offset(1, 0).EntireRow
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")

'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name

    If Fname <> ThisWorkbook.Name Then

        Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
        Set originsheet = wkbkorigin.Worksheets("Table 1")

        With RngDest
            .Cells(1).Value = originsheet.Range("A3").Value
            .Cells(2).Value = originsheet.Range("C21").Value
            .Cells(3).Value = originsheet.Range("E21").Value
            .Cells(4).Value = originsheet.Range("A23").Value
            .Cells(5).Value = originsheet.Range("A31").Value
        End With

        wkbkorigin.Close SaveChanges:=False   'close current file
        Set RngDest = RngDest.Offset(1, 0)

    End If

    Fname = Dir()     'get next file
Loop
End Sub

请帮助我使用以下代码进行更改，因为我正确地使用它。

需要复制以黄色突出显示的所有值。 唯一常见的是突出显示的单元格上方的单词或文本，因为单元格的范围会根据工作簿而变化。

Answer 1

使用Find()和.Offset()方法：

With RngDest
        .Cells(1).Value = originsheet.Cells.Find("NAME").Offset(1, 0).Value
        .Cells(2).Value = originsheet.Cells.Find("DATE").Offset(1, 0).Value
        .Cells(3).Value = originsheet.Cells.Find("PLACE").Offset(1, 0).Value
        '// etc ...
End With