如何匹配不同工作表中的标题并在匹配时复制/粘贴第二行？

Question

我有一个包含两个不同工作表的 Excel 文档。 工作表 1 有许多带有标题名称和空白行的列。 工作表 2 中的一些列具有准确的标题名称和第二行中的条目。

我想创建一个宏来查看 Sheet 2 中的所有列标题并在 Sheet1 中找到它们对应的匹配项。找到匹配项后，我需要将 Sheet2 标题第 2 行中的条目复制到 sheet1 的匹配标题中。 Sheet1 中的某些条目没有匹配项，将保持空白。

我目前的 2 张床单：

表 1

apple   | orange | mango  | grape  | banana
------------------------------------------
[BLANK] |[BLANK] |[BLANK] |[BLANK] | [BLANK]  

表 2

orange | mango  | banana 
--------------------------
yumm   | yuck   | maybe    

宏运行后我想要什么：

表 1

apple   | orange | mango  | grape  | banana
------------------------------------------
[BLANK] |yumm    |yuck    |[BLANK] | maybe  

我正在学习 VBA，大约 2 周后。我无法让我的程序执行此操作。我见过类似的问题，但它们通常只匹配一列中的一项，而不是多列中的多个名称。我尝试过的代码并没有像我需要的那样做任何事情。

此外，这必须作为宏或函数来完成，因为程序将被发送给需要已经自动完成的用户。我认为执行 VLOOKUP 在这里不起作用，因为在用户输入它们之前我不会知道任一工作表中的列数，在这种情况下，程序将自动填充匹配行的第 2 行。有什么想法吗？

Answer 1

假设工作表名称为Sheet1 和Sheet2，这将完成。

Sub colLookup()

Dim ShtOne As Worksheet, ShtTwo As Worksheet
Dim shtOneHead As range, shtTwoHead As range
Dim headerOne As range, headerTwo As range

Set ShtOne = Sheets("Sheet1")
Set ShtTwo = Sheets("Sheet2")

Dim lastCol As Long

'get all of the headers in the first sheet, assuming in row 1
lastCol = ShtOne.Cells(1, Columns.count).End(xlToLeft).column
Set shtOneHead = ShtOne.range("A1", ShtOne.Cells(1, lastCol))

'get all of the headers in second sheet, assuming in row 1
lastCol = ShtTwo.Cells(1, Columns.count).End(xlToLeft).column
Set shtTwoHead = ShtTwo.range("A1", ShtTwo.Cells(1, lastCol))

'actually loop through and find values
For Each headerTwo In shtTwoHead
    For Each headerOne In shtOneHead
        If headerTwo.Value = headerOne.Value Then
            headerOne.Offset(1, 0).Value = headerTwo.Offset(1, 0).Value
        End If
    Next headerOne
Next headerTwo


End Sub

编辑：根据 cmets 中的讨论，需要一种复制和粘贴方法。这将单元格保持为下拉列表，尽管我认为下拉列表仍然无效。如果不希望这样做，可以将xlPasteAll 更改为其他格式，例如xlPasteValues。其他列在Microsoft's documentation。

Sub colLookup()

Dim ShtOne As Worksheet, ShtTwo As Worksheet
Dim shtOneHead As range, shtTwoHead As range
Dim headerOne As range, headerTwo As range

Set ShtOne = Sheets("Sheet1")
Set ShtTwo = Sheets("Sheet2")

Dim lastCol As Long

'get all of the headers in the first sheet, assuming in row 1
lastCol = ShtOne.Cells(1, Columns.count).End(xlToLeft).column
Set shtOneHead = ShtOne.range("A1", ShtOne.Cells(1, lastCol))

'get all of the headers in second sheet, assuming in row 1
lastCol = ShtTwo.Cells(1, Columns.count).End(xlToLeft).column
Set shtTwoHead = ShtTwo.range("A1", ShtTwo.Cells(1, lastCol))

'actually loop through and find values
For Each headerTwo In shtTwoHead
    For Each headerOne In shtOneHead
        If headerTwo.Value = headerOne.Value Then
            headerTwo.Offset(1, 0).Copy
            headerOne.Offset(1, 0).PasteSpecial xlPasteAll
            Application.CutCopyMode = False
        End If
    Next headerOne
Next headerTwo


End Sub