مقارنة بين قائمتين وترتيب المكرر ابجديا

[ابو هاله النبلسي]

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

في الملف المرفق يوجد قائمتين احتاج مقارنة ومطابقة قائمة a مع aa وترتيب الاسماء التابعه لكل قائمة ابجديا حسب الرقم في a و aa 

مقارنة.xlsx

[الرائد77]

تفضل إإيجاد المكرر  و الاسماء  و ترحيل الى الاعمدة  d :e  و ترتيب الاسماء أبجديا.

مقارنة.xlsm

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

بعد اذن اخي الرائد

لا لزوم للحلفات التكرارية لأكثر من 150 صف من البيانات

(يمكن تجربة الكود على قليل من الصفوف 20 صف تقريباً لان الماكرو الذي يعمل على صف واحد يمكنه العمل على الوف الصفوف)

1-استبدال اسم الشيت الى Salim  (لأني لا أفضّل التسمية باللغة العربية لحسن نسخ الكود ولصقه بدون مشاكل اللغة)

2- تنفيذ هذا الكود

Option Explicit
Sub Compaire_two_Col()
    
    Dim S As Worksheet
    Dim Res_range As Range
    Dim LrA%
    
    Set S = Sheets("Salim")
    LrA = S.Cells(Rows.Count, 1).End(3).Row
    Set Res_range = S.Range("D1").CurrentRegion
 
 If Res_range.Rows.Count > 1 Then _
 Res_range.Offset(1).Resize(Res_range.Rows.Count).Clear
 
 S.Range("D2").Resize(LrA - 1, 2).Value = _
 S.Range("A2").Resize(LrA - 1, 2).Value
 Set Res_range = S.Range("D1").CurrentRegion

 With Res_range
 .Sort Key1:=Res_range.Cells(1, 1), Header:=1
 .RemoveDuplicates Columns:=1, Header:=xlYes
 End With
 Set Res_range = S.Range("D1").CurrentRegion
 With Res_range.Offset(1).Resize(Res_range.Rows.Count - 1)
  .Borders.LineStyle = 1
  .InsertIndent 1
  .Font.Bold = True
  .Interior.ColorIndex = 35
 End With
End Sub

الملف مرفق

Compair_data.xlsm

[ابو هاله النبلسي]

الاساتذة الافاضل لو تعلمون كم انا في مئازق بسبب هذا العمل واتمنى المساعدة  في القائمة الاولى ارقام .... ماريده من حل ..... انه ناخذ الارقام من القائمة الاولى نحبث عنها في القائمة الثانية كمثل استخدام دالة match ابحث عن الارقام في القائمة الثانية تظهر لي رقم السطر عنده سحبها للاسفل لكل الارقام احتاج كيفية  فلترة ما تم استخراجه من دالة match وترتيب وفلترة من الاسفل للاعلى للنتيجة من الدالة لكني لا استطيع ان افلترها من الاسفل للاعلى  ..........لان المشكله بسببي في العمل تم توزيع الارقام في القائمة a وهي مبالغ الى اسماء من قائمة aa وانا في مشكله كبيرة منتظر مساعدتكم 

@سليم حاصبيا او انه الارقام في قائمة a اين اجدها في القائمة aa لاي اسم ذهبت او تقابل من في القائمة aa وترتيبها ابجديا حتى اعرف انه الارقام ذهب للخشص الخطا 

لان اساس المشكله الارقام في قائمة a اخذت الاسماء الخطا ويجب ان تذهب الى اسماء من قائمة aa الصح 

مقارنة.xlsm

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

المشكلة ان الأسماء في الفائمة الثانية ليست نفسها في القائمة الأولى

مثلاُ الاسم (فريده طه اسماعيل داود) موجود في القائمة الاولى وغير موجود في الثانية

اقترح ان ترفع ملفاً نموذجاً  فيه بعض البيانات ( 10 اسطر من كل جدول لا اكثر)مع النتائج المتوقعة  يدوياً (بدون فلتره اذا اردت)

يمكن استبدال الأرقام في النموذج بارقام بسيطة 1و2و3 الخ... ولاسماء باسماء بسيطة مثلاً (A1,A2,A3.... )

لمعرفة المطلوب بالضبط  بعد ذلك يمكن تعميم الكود على باقي الجدول

[ابو هاله النبلسي]

@سليم حاصبيا وهو المطلوب انا اريد ان اعرف هذه الارقم في القائمة A اين ذهبت على اسماء قائمة AA لكن كيف يتم ذلك الهمة فيك استاذ

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

جرب هذا الكود (بعد تسمبة الشيت باسم Data)

Option Explicit
Sub Compaire_two_Col()
 With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
 End With
    Dim D As Worksheet
    Dim Res_range As Range
    Dim LrA%, i%, x%
    Dim DIC As Object
    
    Set D = Sheets("Data")
    Set Res_range = D.Range("D1").CurrentRegion
    Set DIC = CreateObject("Scripting.Dictionary")
   
   LrA = D.Cells(Rows.Count, 1).End(3).Row
 If Res_range.Rows.Count > 1 Then _
 Res_range.Offset(1).Resize(Res_range.Rows.Count).Clear
  With D
      For i = 2 To LrA
        Set Res_range = D.Range("J2:J" & LrA).Find(D.Cells(i, 2), lookat:=1)
          If Not Res_range Is Nothing Then
            x = Res_range.Row
            DIC(D.Cells(i, 2).Value) = D.Range("k" & x).Value
          End If
      Next
      If DIC.Count = 0 Then GoTo MY_End
       D.Range("E2").Resize(DIC.Count) = Application.Transpose(DIC.Items)
       .Range("F2").Resize(DIC.Count) = Application.Transpose(DIC.Keys)
       
       Set Res_range = D.Range("E1").CurrentRegion
          With Res_range
           .Sort Key1:=.Cells(1, 1), Header:=1
               With .Offset(1).Resize(.Rows.Count - 1)
                 .Borders.LineStyle = 1
                 .InsertIndent 1
                 .Font.Bold = True: .Font.Size = 14
                 .Interior.ColorIndex = 19
               End With
          End With
   End With
MY_End:
  With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
 End With
End Sub

File Include

 

Abd_rahman.xlsm

[abouelhassan]

بارك الله فيك استاذنا سليم حاصبيا

[أحمد يوسف]

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

فين انت من كل هذه الإجابات؟ !!!!!

أين الضغط على الإعجاب  ؟!!!💙