Merge Multiple Data of Single Unique Value from Separate Worksheet Into A New Worksheet By Using VBA

Finally, at 1.15 am, I got this program running by using my dummy data. This VBA Excel codes is very useful which I have created is very powerful such that it could reduce manual working time of complex data merging work from days to minutes.

It is my pleasure to share this codes with any interested parties. As usual this codes are customised to my worksheet data properties. I have also included msgbox pop-up to check any errors that may have occured during the running of the codes. These msgbox can be deleted once you feel that the result of the codes is satisfactory.

If you have any queries, please do not hesitate to contact me.

VBA codes :-


Sub CopywithAutoFilterToNewSheet()

Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WSFiltered As Worksheet
Dim LastRowFilteredWorksheet As Long, LastRowIntegratedWorksheet As Long
Dim LastRowInitialWorksheet As Long
Dim NextColumn As Long
Dim x As Long, Y As Long, z As Long

Set WS1 = Worksheets("sheet1")
Set WS2 = Worksheets("sheet2")

Set FilterRange = WS1.Range("A1:C" & Rows.Count)

WS1.AutoFilterMode = False
WS2.AutoFilterMode = False

With Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet2")
LastRowInitialWorksheet = .Cells(.Rows.Count, 1).End(xlUp).Row
End With

MsgBox "No. of Rows:" & LastRowInitialWorksheet

For x = 1 To 1

NextColumn = Cells(x, Columns.Count).End(xlToLeft).Column + 1

FilterRange.AutoFilter Field:=1, Criteria1:="=" & WS2.Cells(x + 1, 1).Value
FilterRange.AutoFilter Field:=2, Criteria1:="=" & WS2.Cells(x + 1, 2).Value

WS1.AutoFilter.Range.Copy
With Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet3").Cells(x, NextColumn)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

With Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet3")
LastRowFilteredWorksheet = .Cells(.Rows.Count, NextColumn).End(xlUp).Row
End With

MsgBox "No. of Rows:" & LastRowFilteredWorksheet

For Y = 1 To LastRowFilteredWorksheet - 2
Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet4").Cells(x + 2, 1).EntireRow.Insert
Next

WS1.AutoFilter.Range.Copy
With Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet4").Cells(x, NextColumn)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

With Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet4")
LastRowIntegratedWorksheet = .Cells(.Rows.Count, 4).End(xlUp).Row
End With

MsgBox "No. of Rows:" & LastRowIntegratedWorksheet

Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet3").UsedRange.ClearContents

WS1.AutoFilterMode = False

Next

For x = 2 To LastRowInitialWorksheet

NextColumn = Cells(x, Columns.Count).End(xlToLeft).Column + 1

FilterRange.AutoFilter Field:=1, Criteria1:="=" & WS2.Cells(x + 1, 1).Value
FilterRange.AutoFilter Field:=2, Criteria1:="=" & WS2.Cells(x + 1, 2).Value

WS1.AutoFilter.Range.Copy
With Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet3").Cells(1, NextColumn)
.PasteSpecial xlPasteValues
End With

With Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet3")
LastRowFilteredWorksheet = .Cells(.Rows.Count, NextColumn).End(xlUp).Row
End With

MsgBox "No. of Rows:" & LastRowFilteredWorksheet

For Y = 1 To LastRowFilteredWorksheet - 2

Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet4").Cells(LastRowIntegratedWorksheet + 2, 1).EntireRow.Insert

Next

WS1.AutoFilter.Range.Copy

With Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet4").Cells(LastRowIntegratedWorksheet + 1, NextColumn - 3)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

For z = 1 To LastRowFilteredWorksheet
Cells(z + LastRowIntegratedWorksheet + 1, 4).Cut Cells(z + LastRowIntegratedWorksheet, 4)
Cells(z + LastRowIntegratedWorksheet + 1, 5).Cut Cells(z + LastRowIntegratedWorksheet, 5)
Cells(z + LastRowIntegratedWorksheet + 1, 6).Cut Cells(z + LastRowIntegratedWorksheet, 6)
Next
End With

With Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet4")
LastRowIntegratedWorksheet = .Cells(.Rows.Count, 4).End(xlUp).Row
End With

MsgBox "No. of Rows:" & LastRowIntegratedWorksheet

Workbooks("TestMergeDifferentWorksheet.xlsm").Sheets("Sheet3").UsedRange.ClearContents

WS1.AutoFilterMode = False

Next

End Sub