الفرق بين عمودين

[علاء20]

السلام عليكم

 مطلوب معادلة لاظهار الاختلافات بين العمود 

A

Bوالعمود

Cمع اظهار الارقام المختلفة في العمود

Aعلما بوجود ارقام مكررة في العمود 

الشكر لكم ... تـــم تعديل رفع الملف بدون ضغط , فممنوع رفع الملف مضغوط طالما حجمه صغير

المقارنة مع تكرار القيم.xlsx

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

ربما كان المطلوب

Alla_20.xlsx

[علاء20]

السلام عليكم

للاسف ليس هو المطلوب

cالمطلوب الناتج يكون في العمود

عبارة عن قيميتين 

17

17

bلان الارقام موجودة ولكن عدد الرقم 17 ثلاث مرات وفي العمود 

مرة واحدة فقط

 

KM	RG	المطلوب المبالغ الموجودة في العمود الأول وغير موجودة في العمود الثاني فقط
17.000	90.000	17.000
90.000	30.000	17.000
17.000	15.000
30.000	17.000
15.000
17.000

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

تم التعديل (الصفخة Salim)

Alla_20_1.xlsx

[علاء20]

السلام عليكم

للاسف

لو غيرت الارقام لاتعمل المعادلة

			list		count
17	90		17		2
85	30		17
17	15		مفروض يكون رقم 85
30	17
15	9
17

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

في هذه الحالة الماكرو هو الحل

Option Explicit
Sub In_A_But_Not_B()
 Dim Ra As Range, Rb As Range, _
      a%, b%, i%, Bol As Boolean
 Dim Dic As Object
 With Sheets("Salim")
    .Range("D2").CurrentRegion.Offset(1).ClearContents
     a = .Cells(Rows.Count, 1).End(3).Row
     b = .Cells(Rows.Count, 2).End(3).Row
     If a < 2 Or b < 2 Then Exit Sub
     
     Set Ra = .Range("A2:A" & a)
     Set Rb = Range("B2:B" & b)
     Set Dic = CreateObject("Scripting.Dictionary")
    For i = 2 To a
      Bol = IsError(Application.Match(.Cells(i, 1), Rb, 0))
       If Bol Then
          Dic(Dic.Count + 1) = .Cells(i, 1).Value
       End If
     Next
     If Dic.Count Then
      .Range("E2").Resize(Dic.Count) = _
        Application.Transpose(Dic.items)
      .Range("D2").Resize(Dic.Count) = _
        Application.Transpose(Dic.keys)
      .Range("f2") = Dic.Count
     End If
  End With
End Sub

الملف مرفق

Alla_20_2.xlsm

[علاء20]

السلام عليكم

Aللاسف ليس الحل لأنه من المفترض وجود رقم 17 مكرر 3 مرات في العمود 

Bومكرر 1 مرة في العمود

فمفترض يظهر الرقم 

17

17

Cفي العمود

Table1	Table2		#	list	count
17	90		1	85	4
85	30		2	170
17	15		3	85
30	17		4	41
15	9
17
170
85
41

[نزار سليمان عيد]

ممكن تظهر شكل النتيجة النهائية حسب شرحك يدويا

 

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

التعديل على الكود كما تريد

Option Explicit
'++++++++++++++++++++++++++++++
 Dim Ra As Range, Rb As Range
 Dim a%, b%, i%, Bol As Boolean
 Dim m%, t%
 Dim Ky
 Dim S As Worksheet
 Dim Dic_Unique As Object
 Dim Dic As Object
'++++++++++++++++++++++++++++++++++++++
Sub Unique_item()

    Set S = Sheets("Salim")
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Dic_Unique = CreateObject("Scripting.Dictionary")
     a = S.Cells(Rows.Count, 1).End(3).Row
     b = S.Cells(Rows.Count, 2).End(3).Row
     Set Ra = S.Range("A2:A" & a)
     Set Rb = Range("B2:B" & b)
 
 For i = 2 To a
    Dic_Unique(S.Cells(i, 1).Value) = ""
 Next
End Sub
'"""""""""""""""""""""""""""""""""""""""""""
Sub Extract()
Unique_item

S.Range("D2").CurrentRegion.Offset(1).ClearContents
 If Dic_Unique.Count Then
   For Each Ky In Dic_Unique.keys
    Bol = IsError(Application.Match(Ky, Rb, 0))
     If Bol Then
      Dic(Ky) = 1
     Else
      Dic(Ky) = Application.CountIf(Ra, Ky) - 1
     End If
   Next Ky
 End If
 If Dic.Count Then
    m = 2
    For Each Ky In Dic.keys
      If Dic(Ky) <> 0 Then
         S.Range("E" & m).Resize(Dic(Ky)) = Ky
       m = m + Dic(Ky)
     End If
    Next
     t = S.Range("D2").CurrentRegion.Rows.Count
         If t > 1 Then
           S.Range("F2") = t - 1
           S.Range("D2").Resize(t - 1).Value = _
           Evaluate("Row(1:" & t - 1 & ")")
         End If
 End If
 
 Set S = Nothing
 Set Ra = Nothing: Set Rb = Nothing
 Set Dic_Unique = Nothing
 Set Dic = Nothing
End Sub

الملف من جديد

Alla_20_3.xlsm

[علاء20]

السلام عليكم

تمام تمام هو المطلوب شاكر مجهودك وفققك الله 

لاتمام الفائدة  هل يمكن عمل عمود للارقام الموجودة في العمود

B

وغير موجودة في العمود 

A

 

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

فقط تغيير المعطيات

Option Explicit
'++++++++++++++++++++++++++++++
 Dim Ra As Range, Rb As Range
 Dim a%, b%, i%, Bol As Boolean
 Dim m%, t%
 Dim Ky
 Dim S As Worksheet
 Dim Dic_Unique As Object
 Dim Dic As Object
'++++++++++++++++++++++++++++++++++++++
Sub Item_Unique()

    Set S = Sheets("Salim")
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Dic_Unique = CreateObject("Scripting.Dictionary")
     a = S.Cells(Rows.Count, 1).End(3).Row
     b = S.Cells(Rows.Count, 2).End(3).Row
     Set Ra = S.Range("A2:A" & a)
     Set Rb = Range("B2:B" & b)
 
 For i = 2 To b
    Dic_Unique(S.Cells(i, 2).Value) = ""
 Next
End Sub
'"""""""""""""""""""""""""""""""""""""""""""
Sub ExtractB()
Item_Unique

S.Range("K2").CurrentRegion.Offset(1).ClearContents
 If Dic_Unique.Count Then
   For Each Ky In Dic_Unique.keys
    Bol = IsError(Application.Match(Ky, Ra, 0))
     If Bol Then
      Dic(Ky) = 1
     Else
      Dic(Ky) = Application.CountIf(Rb, Ky) - 1
     End If
   Next Ky
 End If
 If Dic.Count Then
    m = 2
    For Each Ky In Dic.keys
      If Dic(Ky) <> 0 Then
         S.Range("K" & m).Resize(Dic(Ky)) = Ky
       m = m + Dic(Ky)
     End If
    Next
     t = S.Range("k2").CurrentRegion.Rows.Count
         If t > 1 Then
           S.Range("L2") = t - 1
           S.Range("J2").Resize(t - 1).Value = _
           Evaluate("Row(1:" & t - 1 & ")")
         End If
 End If
 
 Set S = Nothing
 Set Ra = Nothing: Set Rb = Nothing
 Set Dic_Unique = Nothing
 Set Dic = Nothing
End Sub

الملف مرفق

Alla_20_4.xlsm

[علاء20]

السلام عليكم 

الاخ سليم حاصبيا

 اشكرك على المجهود الرائع