Option Explicit
Dim My_sh As Worksheet
Dim Rg As Range, Find_rg As Range
Dim roA%, roB%, Ro, i%, K, ky, m
Dim Dic_A As Object
Dim Rg_A, RG_B
'++++++++++++++++++++++++++++++
Sub Get_alL_data()
Initialize
Range("c2").Resize(Ro * 2, 5).ClearContents
Common_Names
In_A_Only
In_B_Only
In_A_Only_Plus_In_B_Only
All_Unique
End Sub
'================================
Sub Initialize()
Set My_sh = Sheets("ورقة1")
Set Dic_A = CreateObject("Scripting.Dictionary")
roA = My_sh.Cells(Rows.Count, 1).End(3).Row
roB = My_sh.Cells(Rows.Count, 2).End(3).Row
Ro = Application.Max(roA, roB)
Set Rg_A = Range("A1:A" & Ro)
Set RG_B = Range("B1:B" & Ro)
End Sub
'=====================================
Sub Common_Names()
For i = 2 To Ro
If Cells(i, 1) <> vbNullString Then
Set Find_rg = RG_B.Find(Cells(i, 1), lookat:=1)
If Not Find_rg Is Nothing Then
Dic_A(Cells(i, 1)) = vbNullString
End If
End If
Next i
Cells(2, 3).Resize(Dic_A.Count) = _
Application.Transpose(Dic_A.keys)
Dic_A.RemoveAll
End Sub
'=============================
Sub In_A_Only()
For i = 2 To Ro
If Cells(i, 1) <> vbNullString Then
Set Find_rg = RG_B.Find(Cells(i, 1), lookat:=1)
If Find_rg Is Nothing Then
Dic_A(Cells(i, 1)) = vbNullString
End If
End If
Next i
Cells(2, 4).Resize(Dic_A.Count) = _
Application.Transpose(Dic_A.keys)
Dic_A.RemoveAll
End Sub
'=============================
Sub In_B_Only()
For i = 2 To Ro
If Cells(i, 2) <> vbNullString Then
Set Find_rg = Rg_A.Find(Cells(i, 2), lookat:=1)
If Find_rg Is Nothing Then
Dic_A(Cells(i, 2)) = vbNullString
End If
End If
Next i
Cells(2, 5).Resize(Dic_A.Count) = _
Application.Transpose(Dic_A.keys)
Dic_A.RemoveAll
End Sub
'================================
Sub In_A_Only_Plus_In_B_Only()
For i = 2 To Ro
If Cells(i, 1) <> vbNullString Then
Set Find_rg = RG_B.Find(Cells(i, 1), lookat:=1)
If Find_rg Is Nothing Then
Dic_A(Cells(i, 1)) = vbNullString
End If
End If
Next i
'+++++++++++++++++++++++++++++++++
For i = 2 To Ro
If Cells(i, 2) <> vbNullString Then
Set Find_rg = Rg_A.Find(Cells(i, 2), lookat:=1)
If Find_rg Is Nothing Then
Dic_A(Cells(i, 2)) = vbNullString
End If
End If
Next i
Cells(2, 6).Resize(Dic_A.Count) = _
Application.Transpose(Dic_A.keys)
Dic_A.RemoveAll
End Sub
'+++++++++++++++++++++++++++++
Sub All_Unique()
For i = 2 To Ro
For K = 1 To 2
Dic_A(Cells(i, K).Value) = ""
Next K
Next i
Cells(2, 7).Resize(Dic_A.Count) = _
Application.Transpose(Dic_A.keys)
Dic_A.RemoveAll
End Sub
تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق
