معادلة استخراج الأسماء الناقصة من صفحتين ووضعهم بصفحة ثالثة

[أبو مسلم الحازم]

السلام عليكم و رحمة الله 

ممكن من حضرااتكم طريقة عمل الآتي

استخراج الاسماء الناقصة التي في الشيت2 من الشيت 1  ونسخها في الشيت3

مرفق الملف

وبارك الله فيكم

عنوان مخالف ... تـــم تعديل وتغيير عنوان المشاركة ليعبر عن طلبك 

2021.xlsx

[سليم حاصبيا]

 في المرفق 3 ماكرو

اختر ما تريد للنشغيل

Names.xlsm

[أبو مسلم الحازم]

أخي سليم اشكرك على الرد لكن الكود الثاني لا يعمل

 

B NOT A

وهذا هو المطلوب

 

 

[أبو مسلم الحازم]

ترحيل القيم الغير مشتركة بين

ad1 و ad2 

الى

ad3

وشكرا

مرفق ملف

 

dam.xlsx

[سليم حاصبيا]

تمت الاجابة عن هذا السؤال في مشاركة سابقة

كان يجب ادراج هذا الامر فيها

تم التعدبل للحصول على كل الحبارات

Option Explicit

Dim A As Worksheet, B As Worksheet, C As Worksheet
Dim Rg_A As Range, Rg_B As Range, Rg_c1 As Range
Dim LA%, LB%, LC%
Dim Found_range As Range
Dim I%, M%
'++++++++++++++++++++++++++
Sub Dedut()
Set A = Sheets("List_A")
Set B = Sheets("List_B")
Set C = Sheets("List_C")
LA = A.Cells(Rows.Count, 1).End(3).Row
LB = B.Cells(Rows.Count, 1).End(3).Row
Set Rg_A = A.Range("A1:a" & LA)
Set Rg_B = B.Range("A1:a" & LA)

End Sub
'++++++++++++++++++++++++++++++++
Sub In_A_not_In_B()
Dedut
M = 2
LC = C.Cells(Rows.Count, 3).End(3).Row
If LC > 1 Then
C.Range("C2:C" & LC).ClearContents
End If
For I = 1 To LA
If A.Range("A" & I) <> vbNullString Then
  If Application.CountIf(A.Range("A1:A" & I), A.Range("A" & I)) = 1 Then
   Set Found_range = Rg_B.Find(A.Range("A" & I), lookat:=1)
   If Found_range Is Nothing Then
    C.Cells(M, 3) = A.Range("A" & I)
    M = M + 1
   End If
  End If
End If
Next

End Sub
'+++++++++++++++++++++++++++++++++++
Sub In_B_not_In_A()
Dedut
M = 2
LC = C.Cells(Rows.Count, 5).End(3).Row
If LC > 1 Then
C.Range("E2:E" & LC).ClearContents
End If
For I = 1 To LB
If B.Range("A" & I) <> vbNullString Then
  If Application.CountIf(B.Range("A1:A" & I), A.Range("A" & I)) = 0 Then
   Set Found_range = Rg_A.Find(B.Range("A" & I), lookat:=1)
   If Found_range Is Nothing Then
    C.Cells(M, 5) = B.Range("A" & I)
    M = M + 1
   End If
  End If
End If
Next

End Sub
'++++++++++++++++++++++++++++++++++++++
Sub In_A_And_B()
Dedut
M = 2
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
LC = C.Cells(Rows.Count, 7).End(3).Row
If LC > 1 Then
C.Range("G2:G" & LC).ClearContents
End If

For I = 1 To LA
    If A.Range("A" & I) <> vbNullString Then
     dic(A.Range("A" & I).Value) = A.Range("A" & I).Value
    End If
Next

For I = 1 To LB
If B.Range("A" & I) <> vbNullString Then
 dic(B.Range("A" & I).Value) = A.Range("A" & I).Value
End If
Next

If dic.Count Then
  C.Cells(M, 7).Resize(dic.Count).Value = _
 Application.Transpose(dic.Keys)
 End If


End Sub
'+++++++++++++++++++++++++++++
Sub Not_common()
Dedut
M = 2
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
LC = C.Cells(Rows.Count, "I").End(3).Row
If LC > 1 Then
C.Range("I2:I" & LC).ClearContents
End If

For I = 1 To LA
    If A.Range("A" & I) <> vbNullString And _
    Application.CountIf(Rg_B, A.Range("A" & I).Value) = 0 Then
      dic(A.Range("A" & I).Value) = A.Range("A" & I).Value
    End If
Next

For I = 1 To LB
If B.Range("A" & I) <> vbNullString And _
 Application.CountIf(Rg_A, B.Range("A" & I).Value) = 0 Then
 dic(B.Range("A" & I).Value) = B.Range("A" & I).Value
End If
Next

If dic.Count Then
  C.Cells(M, 9).Resize(dic.Count).Value = _
 Application.Transpose(dic.Keys)
 End If


End Sub
'+++++++++++++++++++++++++++++
Sub common()
Dedut
M = 2
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
LC = C.Cells(Rows.Count, "K").End(3).Row
If LC > 1 Then
C.Range("K2:K" & LC).ClearContents
End If

For I = 1 To LA
    If A.Range("A" & I) <> vbNullString And _
    Application.CountIf(Rg_B, A.Range("A" & I).Value) > 0 Then
      dic(A.Range("A" & I).Value) = A.Range("A" & I).Value
    End If
Next

For I = 1 To LB
If B.Range("A" & I) <> vbNullString And _
 Application.CountIf(Rg_A, B.Range("A" & I).Value) > 0 Then
 dic(B.Range("A" & I).Value) = B.Range("A" & I).Value
End If
Next

If dic.Count Then
  C.Cells(M, 11).Resize(dic.Count).Value = _
 Application.Transpose(dic.Keys)
 End If


End Sub

الملف من جديد

 

Names_allVarinat.xlsm