根据标准将数据从一张表合并到另一张表，并仅填充特定单元格

Question

I have two data sources I wish to combine.

Sheet 1

Data source on Sheet1 contains 2 columns: AccountID and Cost. Source is in cells A3:B3 (data row starts in A4) for 1 to N records. A secondary cell contains the year value for all records to be used in this source. It is in cell D1.

Sheet 2

Data source on Sheet2 contains 6 columns and in range A1:F1 (data starts on row 2): Year, AccountID, Location, Phone#, Email type, & Cost. Data continues for 1 to N records.

I wish to join the records of both tables based on the AccountID of each range of data (Sheet1 column A, Sheet2 column B), where the year (sourced on Sheet1,D1) is added to all records on the Sheet2 data. and records matching by AccountID. The data is appended /added to Sheet2 on last available row.

Example #1

AccountID "1234" is on Sheet1 but not on Sheet2. Year value (Sheet1.D1) contains 2020, The end result would have a new row added with the AccountID of "1234" into Sheet2, the associated Cost value. and a year of 2020.

Example #2

AccountID "1234" is on sheet1 and also on Sheet2. The record on Sheet2 has a year value of 2019. The record on Sheet1 has the year 2020 associated with it (Sheet1.D1 cell value), The end result would have two rows of data for AccountID of "1234" in Sheet2, one for the 2019 record and one for 2020 record. as found on Sheet1 data source, The latter would not include Location, Phone#, or Email type values as they are not specified

Sheet1

Sheet2

Sheet2 once Sheet1 data is appended

Answer 1

Maybe something like this?

Sub test()
Set rng_ID = Sheets("Sheet2").Range("B:B") 'set ID range on sheet2
oYear = Sheets("Sheet1").Range("D1").Value 'get year value on sheet1
Set Rng = Sheets("Sheet1").Range("A4", Sheets("Sheet1").Range("A4").End(xlDown)) 'set ID range on sheet1

With Sheets("Sheet2")
For Each cell In Rng 'loop to each cell in ID range on sheet1
oCost = cell.Offset(0, 1).Value 'set the cost value
Set c = rng_ID.Find(cell.Value, lookat:=xlWhole) 'find if the cell value is in ID range on sheet2
    If Not c Is Nothing Then 'if found
    Set xCopy = .Range(c, c.Offset(0, 4)) 'set the range found to be copied
    c.Offset(1, 0).EntireRow.Insert 'insert entire row below the found cell
    xCopy.Copy Destination:=c.Offset(1, 0) 'copy the range above then paste
    c.Offset(1, -1).Value = oYear 'fill the year
    c.Offset(1, 4).Value = oCost 'file the cost
    Else 'if not found
    Set oFill = Sheets("Sheet2").Range("B500000").End(xlUp).Offset(1, 0) 'set the last blank cell in column B sheet2
    oFill.Offset(0, -1).Value = oYear 'fil the year
    oFill.Offset(0, 4).Value = oCost 'fill the cost
    oFill.Value = cell.Value 'fill the ID
    End If
Next cell
End With

'unmark the line below which one you want     
'Call SortByYearThenByID
'Call SortByIDThenByYear
End sub

I try to add it with a sort code, maybe the result as you want it

Sub SortByYearThenByID()
Set rngSort = Sheets("Sheet2").Range("A1", Range("F1").End(xlDown))

Sheets("Sheet2").Sort.SortFields.Clear
        rngSort.Sort Key1:=rngSort.Columns(1), Key2:=rngSort.Columns(2), Order1:=xlAscending, Header:=yes
End Sub

Sub SortByIDThenByYear()
Set rngSort = Sheets("Sheet2").Range("A1", Range("F1").End(xlDown))
Sheets("Sheet2").Sort.SortFields.Clear
        rngSort.Sort Key1:=rngSort.Columns(2), Key2:=rngSort.Columns(1), Order1:=xlAscending, Header:=yes
End Sub