Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Merging two simple worksheets based on header

Posted on 2013-01-14
3
Medium Priority
?
424 Views
Last Modified: 2013-02-07
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
Comment
Question by:gisvpn
  • 3
3 Comments
 
LVL 24

Expert Comment

by:Steve
ID: 38773967
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
 
LVL 24

Accepted Solution

by:
Steve earned 2000 total points
ID: 38773975
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
 
LVL 24

Assisted Solution

by:Steve
Steve earned 2000 total points
ID: 38774219
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

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft's Excel has many features that most people will never need nor take advantage of.  Conditional formatting is one feature that you may find a necessity once you start using it.
Microsoft has changed the look and feel of Azure AD and Microsoft account sign-in pages so that you will have a more unified look and feel when moving between the two interfaces.
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…
In this video you will find out how to export Office 365 mailboxes using the built in eDiscovery tool. Bear in mind that although this method might be useful in some cases, using PST files as Office 365 backup is troublesome in a long run (more on t…

885 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question