Merge 2 Sheets in 1

[plambertini]

Hi,
I need to merge 2 sheets (sheet1 & sheet2) in one new sheet (sheet3).
In sheet 1 I have in the first column a unique ID and many columns (up to column CL), in sheet 2 I have in the first column the same ID (which appears several times) and few columns (up to column H). I have to merge these 2 sheets into a new and unique sheet (sheet3) in which the unique ID appears for each row and in the following columns (after column CL) all the rows of sheet2 corresponding to that ID.


Thank you in advance for your assistance!

 

[FGaxha]

This is the macro:
Insert Module on Property Window and copy th code below: 'Copy Headers into Master". Run macro and select A1 as reference into your "Master Sheet"

Sub Merge_Sheets()

Dim startRow, startCol, lastRow, lastCol As Long
Dim headers As Range

'Set Master sheet for consolidation
Set mtr = Worksheets("Master")

Set wb = ThisWorkbook
'Get Headers
Set headers = Application.InputBox("Select the Headers", Type:=8)

'Copy Headers into master
headers.Copy mtr.Range("A1")
startRow = headers.Row + 1
startCol = headers.Column

Debug.Print startRow, startCol
'loop through all sheets
For Each ws In wb.Worksheets
'except the master sheet from looping
If ws.Name <> "Master" Then
ws.Activate
lastRow = Cells(Rows.Count, startCol).End(xlUp).Row
lastCol = Cells(startRow, Columns.Count).End(xlToLeft).Column
'get data from each worksheet and copy it into Master sheet
Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
mtr.Range("A" & mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1)
End If
Next ws

Worksheets("Master").Activate

End Sub

 

[mumps]

This macro assumes you have headers in row 1 of sheets 1 and 2, your data starts in row 2 and that sheet3 already exists.

Sub MergeSheets()
    Application.ScreenUpdating = False
    Dim srcWS1 As Worksheet, srcWS2 As Worksheet, desWS As Worksheet, v1 As Variant, v2 As Variant, i As Long, dic As Object
    Set srcWS1 = Sheets("Sheet1")
    Set srcWS2 = Sheets("Sheet2")
    Set desWS = Sheets("Sheet3")
    srcWS1.UsedRange.Copy desWS.Range("A1")
    v1 = srcWS1.Range("A2", srcWS1.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = srcWS2.Range("A2", srcWS2.Range("A" & Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If Not dic.exists(v1(i, 1)) Then
            dic.Add v1(i, 1), i + 1
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If dic.exists(v2(i, 1)) Then
            srcWS2.Range("B" & i + 1).Resize(, 7).Copy desWS.Cells(dic(v2(i, 1)), desWS.Columns.Count).End(xlToLeft).Offset(0, 1)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[plambertini]

This macro assumes you have headers in row 1 of sheets 1 and 2, your data starts in row 2 and that sheet3 already exists.

Sub MergeSheets()
    Application.ScreenUpdating = False
    Dim srcWS1 As Worksheet, srcWS2 As Worksheet, desWS As Worksheet, v1 As Variant, v2 As Variant, i As Long, dic As Object
    Set srcWS1 = Sheets("Sheet1")
    Set srcWS2 = Sheets("Sheet2")
    Set desWS = Sheets("Sheet3")
    srcWS1.UsedRange.Copy desWS.Range("A1")
    v1 = srcWS1.Range("A2", srcWS1.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = srcWS2.Range("A2", srcWS2.Range("A" & Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If Not dic.exists(v1(i, 1)) Then
            dic.Add v1(i, 1), i + 1
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If dic.exists(v2(i, 1)) Then
            srcWS2.Range("B" & i + 1).Resize(, 7).Copy desWS.Cells(dic(v2(i, 1)), desWS.Columns.Count).End(xlToLeft).Offset(0, 1)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Hi!!! thank you very much!! it works very well but one thing is missing (my fault), the last columns have some blank rows so the data appended gets misaligned. is it possible to always start the queuing from the CN column? thanks in advance

 

[mumps]

Try:

Sub MergeSheets()
    Application.ScreenUpdating = False
    Dim srcWS1 As Worksheet, srcWS2 As Worksheet, desWS As Worksheet, v1 As Variant, v2 As Variant, i As Long, dic As Object
    Set srcWS1 = Sheets("Sheet1")
    Set srcWS2 = Sheets("Sheet2")
    Set desWS = Sheets("Sheet3")
    srcWS1.UsedRange.Copy desWS.Range("A1")
    v1 = srcWS1.Range("A2", srcWS1.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = srcWS2.Range("A2", srcWS2.Range("A" & Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If Not dic.exists(v1(i, 1)) Then
            dic.Add v1(i, 1), i + 1
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If dic.exists(v2(i, 1)) Then
            If desWS.Cells(dic(v2(i, 1)), desWS.Columns.Count).End(xlToLeft).Row <> 92 Then
                srcWS2.Range("B" & i + 1).Resize(, 7).Copy desWS.Cells(dic(v2(i, 1)), 92)
            Else
                srcWS2.Range("B" & i + 1).Resize(, 7).Copy desWS.Cells(dic(v2(i, 1)), desWS.Columns.Count).End(xlToLeft).Offset(0, 1)
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[plambertini]

Try:

Sub MergeSheets()
    Application.ScreenUpdating = False
    Dim srcWS1 As Worksheet, srcWS2 As Worksheet, desWS As Worksheet, v1 As Variant, v2 As Variant, i As Long, dic As Object
    Set srcWS1 = Sheets("Sheet1")
    Set srcWS2 = Sheets("Sheet2")
    Set desWS = Sheets("Sheet3")
    srcWS1.UsedRange.Copy desWS.Range("A1")
    v1 = srcWS1.Range("A2", srcWS1.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = srcWS2.Range("A2", srcWS2.Range("A" & Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If Not dic.exists(v1(i, 1)) Then
            dic.Add v1(i, 1), i + 1
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If dic.exists(v2(i, 1)) Then
            If desWS.Cells(dic(v2(i, 1)), desWS.Columns.Count).End(xlToLeft).Row <> 92 Then
                srcWS2.Range("B" & i + 1).Resize(, 7).Copy desWS.Cells(dic(v2(i, 1)), 92)
            Else
                srcWS2.Range("B" & i + 1).Resize(, 7).Copy desWS.Cells(dic(v2(i, 1)), desWS.Columns.Count).End(xlToLeft).Offset(0, 1)
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

HI, thanks for the very quick response, it works but starting from the CN column it writes only the last record of sheet2 instead I need that starting from the CN column all the rows that have the same ID are inserted (one after the other) (like in the first version you sent me). thank you so much

 

[mumps]

Try:

Sub MergeSheets()
    Application.ScreenUpdating = False
    Dim srcWS1 As Worksheet, srcWS2 As Worksheet, desWS As Worksheet, v1 As Variant, v2 As Variant, i As Long, dic As Object
    Set srcWS1 = Sheets("Sheet1")
    Set srcWS2 = Sheets("Sheet2")
    Set desWS = Sheets("Sheet3")
    srcWS1.UsedRange.Copy desWS.Range("A1")
    v1 = srcWS1.Range("A2", srcWS1.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = srcWS2.Range("A2", srcWS2.Range("A" & Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If Not dic.exists(v1(i, 1)) Then
            dic.Add v1(i, 1), i + 1
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If dic.exists(v2(i, 1)) Then
            If desWS.Cells(dic(v2(i, 1)), desWS.Columns.Count).End(xlToLeft).Column <= 90 Then
                srcWS2.Range("B" & i + 1).Resize(, 7).Copy desWS.Cells(dic(v2(i, 1)), 92)
            Else
                srcWS2.Range("B" & i + 1).Resize(, 7).Copy desWS.Cells(dic(v2(i, 1)), desWS.Columns.Count).End(xlToLeft).Offset(0, 1)
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[alansidman]

An alternative to VBA is Power Query

Combine Data From Multiple Worksheets into a Single Worksheet in Excel

In this tutorial, you'll learn how to quickly combine data from multiple sheets into one single worksheet (using Power Query).

trumpexcel.com