COMBINE Two Sheets and Filter DUPLICATES

Rate this post

MERGE TWO SHEETS IN ONE

This VBA enabled excel sheet merge your data into one sheet with unique and duplicates names.
Our mostly work we do in excel. In excel some we can do advanced work through it’s VBA coding.
After work with some simple coding of VBA we can do our important works in very simple way.
In this workbook if have two sheets containing different data, can merge both sheets with unique and duplicate values. 
These are some simple coding with this you can make your own Data Merger Sheet:
Sub MergeLists()
Dim rA As Range
Dim rB As Range
Dim rCell As Range
Dim lCount As Long
Dim colMerge As New Collection

On Error GoTo ErrorHandle

Application.ScreenUpdating = False
Worksheets(1).Activate
Set rA = Range(Range(“A1”), Range(“A1”).End(xlDown))
Worksheets(2).Activate
Set rB = Range(Range(“A1”), Range(“A1”).End(xlDown))

On Error Resume Next

For Each rCell In rA
   colMerge.Add rCell.Value, rCell.Value
Next
For Each rCell In rB
   colMerge.Add rCell.Value, rCell.Value
Next

On Error GoTo ErrorHandle

Workbooks.Add

With colMerge
   For lCount = 1 To .Count
      Range(“A1”).Offset(lCount – 1).Value = .Item(lCount)
   Next
End With
Set rA = Range(Range(“A1”), Range(“A1”).End(xlDown))
rA.Sort Key1:=Range(“A1”)

BeforeExit:
Set rA = Nothing
Set rB = Nothing
Set rCell = Nothing
Set colMerge = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & ” Procedure MergeLists”
Resume BeforeExit
End Sub

Sub UniqueAndDuplicates()
Dim rA As Range
Dim rB As Range
Dim rCell As Range
Dim vResult()
Dim vResult2()
Dim lCount As Long
Dim lCount2 As Long

On Error GoTo ErrorHandle

Application.ScreenUpdating = False

ThisWorkbook.Worksheets(1).Activate

Set rA = Range(Range(“A1”), Range(“A1”).End(xlDown))
Set rB = Worksheets(2).Range(“A1”)
Set rB = Range(rB, rB.End(xlDown))

ReDim vResult(1 To rA.Count + rB.Count, 1 To 1)
ReDim vResult2(1 To rA.Count + rB.Count, 1 To 1)
For Each rCell In rA
   With rCell
      If WorksheetFunction.CountIf(rB, .Value) = 0 Then
         lCount = lCount + 1
         vResult(lCount, 1) = .Value
      Else
         lCount2 = lCount2 + 1
         vResult2(lCount2, 1) = .Value
      End If
   End With
Next
For Each rCell In rB
   With rCell
      If WorksheetFunction.CountIf(rA, .Value) = 0 Then
         lCount = lCount + 1
         vResult(lCount, 1) = .Value
      Else
         lCount2 = lCount2 + 1
         vResult2(lCount2, 1) = .Value
      End If
   End With
Next

If lCount > 0 Then
   Set rCell = Range(“J2”).Resize(UBound(vResult), 1)
   rCell.Value = vResult()
   With Range(“J1”)
      .Value = “Unique:”
      .Font.Bold = True
   End With
Else
   MsgBox “All values are present in both tables.”
End If
If lCount2 > 0 Then
   Set rCell = Range(“K2”).Resize(UBound(vResult2), 1)
   rCell.Value = vResult2()
   With Range(“K1”)
      .Value = “Duplicates:”
      .Font.Bold = True
   End With
Else
   MsgBox “There were no duplicate values.”
End If

BeforeExit:
Set rA = Nothing
Set rB = Nothing
Set rCell = Nothing
Erase vResult
Erase vResult2
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & ” Procedure UniqueAndDuplicates”
End Sub
How to use this coding :

1.Open Excel
2. Press Alt+F11
3. Create Module
4. Paste the code
5. Create command buttons 
For detailed information watch the above video 
To download the sheet please go through below download link : 
 
Tags: No tags

Add a Comment

Your email address will not be published. Required fields are marked *