How do I match header in different sheets and copy/paste the second row if there's a match?

问题

I have an Excel document with two different Sheets. Sheet 1 has many columns with header names and blank rows. Sheet 2 has some of these columns with exact header names and an entry in the 2nd Row.

I want to make a macro that will look through all the column headers in Sheet 2 and find their corresponding match in Sheet1. When the match is found, I need to copy the entry in Row 2 of the Sheet2 header into the matching header of sheet1. Some entries in Sheet1 will not have matches and will remain blank.

My 2 sheets currently:

Sheet1

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

Sheet2

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

What I want after Macro is run:

Sheet1

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

I am learning VBA, about 2 weeks in. I am having trouble with getting my program to do this. I have seen similar questions but they usually match one item in one column only not multiple names in multiple columns. The codes I have tried have not done anything like what I need.

Also, This has to be done as a macro or function since the program will be sent to a user that needs this to be already done automatically. I think that doing VLOOKUP would not work here since I will not know the number of columns in either sheet until the user enters them in which case the program will automatically populate the row 2 of the matching ones. Any ideas?

回答1:

This will do it, assuming sheet names are Sheet1 and 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

EDIT: as per discussion in comments, a copy and paste method was desired. This keeps the cells as a list drop down, although I do not think the drop down will still work. If that was not desired, it is possible to change the xlPasteAll to other formats, such as xlPasteValues. Others are listed in 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

来源：https://stackoverflow.com/questions/39255708/how-do-i-match-header-in-different-sheets-and-copy-paste-the-second-row-if-there