Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 425
  • Last Modified:

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
0
gisvpn
Asked:
gisvpn
  • 3
2 Solutions
 
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
 
SteveCommented:
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:
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

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now