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.
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
2. Press Alt+F11
3. Create Module
4. Paste the code
5. Create command buttons
