Merging two simple worksheets based on header

hello,

I have a spreadsheet where I would like to merge the data from two worksheets onto another worksheet - an example file is attached ;)

Sheet1 - this is the worksheet I would like to be populated based upon information from sheet2 and sheet3.

I would like the code to run down the name column (column A) on sheet1 and look on sheet2 and sheet 3 for the same matching name which should also appear in Column A on each worksheet (sheet2 and 3). When it finds the same name on sheet2 or sheet3 I would like to copy the data over to Sheet1 and put it under the column where the header matches where it came from, for example the Age from Sheet2 would put the value under Age in sheet1.

I hope this makes sense, but please let me know if you have any questions, hopefully the attached spreadsheet will help.

Many thanks,

GISVPN
Example---Worksheet-Merge.xlsx
gisvpnAsked:
Who is Participating?
 
SteveConnect With a Mentor Commented:
The code below will do the job in VBA too...

Private Function LastRow(TheWorksheet As Worksheet) As Long
If WorksheetFunction.CountA(TheWorksheet.Cells) > 0 Then
    LastRow = TheWorksheet.Cells.Find(What:="*", After:=TheWorksheet.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function
Sub Macro1()

Dim wsRows As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")

    ws.Range("B3").FormulaR1C1 = _
        "=IFERROR(INDEX(Sheet2!C[-1]:C[3],MATCH(Sheet1!RC[-1],Sheet2!C[-1],0),2),"""")"
    ws.Range("C3").FormulaR1C1 = _
        "=IFERROR(INDEX(Sheet3!C[-2]:C,MATCH(Sheet1!RC[-2],Sheet3!C[-2],0),2),"""")"
    ws.Range("D3").FormulaR1C1 = _
        "=IFERROR(INDEX(Sheet2!C[-3]:C[1],MATCH(Sheet1!RC[-3],Sheet2!C[-3],0),3),"""")"
    ws.Range("E3").FormulaR1C1 = _
        "=IFERROR(INDEX(Sheet3!C[-4]:C[-2],MATCH(Sheet1!RC[-4],Sheet3!C[-4],0),3),"""")"
    ws.Range("F3").FormulaR1C1 = _
        "=IFERROR(INDEX(Sheet2!C[-5]:C[-1],MATCH(Sheet1!RC[-5],Sheet2!C[-5],0),5),"""")"
    ws.Range("G3").FormulaR1C1 = _
        "=IFERROR(INDEX(Sheet2!C[-6]:C[-2],MATCH(Sheet1!RC[-6],Sheet2!C[-6],0),4),"""")"
    
    wsRows = LastRow(ws)
    
    ws.Range("B3:G3").AutoFill Destination:=ws.Range("B3:G" & wsRows)
    ws.Range("B3:G" & wsRows).Value = ws.Range("B3:G" & wsRows).Value
End Sub

Open in new window

Example---Worksheet-Merge--coded.xlsm
0
 
SteveCommented:
Attached is the result using formula...

Would you like the dictionary object VBA method or will formula suffice?

Again this can depend upon volume of data.
Example---Worksheet-Merge.xlsx
0
 
SteveConnect With a Mentor Commented:
Below is code using two Dictionaries for the two tables...
This will be about the fastest possible solution...

Option Explicit
Private Function LastRow(TheWorksheet As Worksheet) As Long
If WorksheetFunction.CountA(TheWorksheet.Cells) > 0 Then
    LastRow = TheWorksheet.Cells.Find(What:="*", After:=TheWorksheet.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function
Sub Macro1()

'Create first Dictionary of sheet2
Dim MyDictionary As Scripting.Dictionary
Set MyDictionary = New Scripting.Dictionary
MyDictionary.CompareMode = vbBinaryCompare
Dim arr, x As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet2")
arr = ws.Range("A1:E" & LastRow(ws)).Value
For x = 1 To UBound(arr, 1)
    If Not MyDictionary.Exists(arr(x, 1)) Then MyDictionary.Add arr(x, 1), Array(arr(x, 2), arr(x, 3), arr(x, 4), arr(x, 5))
Next

'Create second Dictionary of sheet3
Dim MyDictionary2 As Scripting.Dictionary
Set MyDictionary2 = New Scripting.Dictionary
MyDictionary2.CompareMode = vbBinaryCompare
Set ws = Sheets("Sheet3")

arr = ws.Range("A1:C" & LastRow(ws)).Value
For x = 1 To UBound(arr, 1)
    If Not MyDictionary2.Exists(arr(x, 1)) Then MyDictionary2.Add arr(x, 1), Array(arr(x, 2), arr(x, 3))
Next

'fill in array of missing data
Set ws = Sheets("Sheet1")
ws.Range("B3:G" & LastRow(ws)).Value = Empty
arr = ws.Range("A3:G" & LastRow(ws)).Value
For x = 1 To UBound(arr)
    If MyDictionary.Exists(arr(x, 1)) Then
        arr(x, 2) = MyDictionary.Item(arr(x, 1))(0)
        arr(x, 4) = MyDictionary.Item(arr(x, 1))(1)
        arr(x, 7) = MyDictionary.Item(arr(x, 1))(2)
        arr(x, 6) = MyDictionary.Item(arr(x, 1))(3)
    End If
    If MyDictionary2.Exists(arr(x, 1)) Then
        arr(x, 3) = MyDictionary2.Item(arr(x, 1))(0)
        arr(x, 5) = MyDictionary2.Item(arr(x, 1))(1)
    End If
Next x

ws.Range("A3:G" & LastRow(ws)).Value = arr

End Sub

Open in new window

0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.