كتابة السنوات المكرر فيها الاسم بخلية أخرى

[أبو سـما]

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

أخواني الكرام مرفق ملف اكسل والمطلوب كتابة السنوات المكرر فيها الاسم وكما هو موضح بالكشف المرفق

وجزاكم الله خيرا

اسماء المشاركين.xlsx

[محي الدين ابو البشر]

Sub test()
    Dim a As Variant, lr, i
   lr = Cells(Rows.Count, 2).End(xlUp).Row
    a = Range("b3:b" & Cells(Rows.Count, 2).End(xlUp).Row).Resize(, 6)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> 0 Then
                If Not .exists(a(i, 1)) Then
                    .Add a(i, 1), a(i, 5)
                Else
                    .Item(a(i, 1)) = .Item(a(i, 1)) & "-" & a(i, 5)
                End If
            End If
        Next
      For i = 1 To lr - 2
       Cells(2 + i, 2).Offset(, 6).Select
   Cells(2 + i, 2).Offset(, 6) = .Item(Cells(2 + i, 2).Value)
      Next
    End With
End Sub

 

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

اخي محي الدين

اظن انه لا حاجة للأمر Select  عدة مرات  مما يرهق البرنامج دون فائدة

ولا حاجة للحلقة التكرارية مرة ثانية لاستخراج  Items من Dictionary 

يكفي وضع هذا السطر ما بين علامات الــــ  +++

Sub test()
    Dim a As Variant, lr, i
   lr = Cells(Rows.Count, 2).End(xlUp).Row
    a = Range("b3:b" & Cells(Rows.Count, 2).End(xlUp).Row).Resize(, 6)
    Cells(3, "H").Resize(100).ClearContents
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> 0 Then
                If Not .exists(a(i, 1)) Then
                    .Add a(i, 1), a(i, 5)
                Else
                    .Item(a(i, 1)) = .Item(a(i, 1)) & "-" & a(i, 5)
                End If
            End If
        Next
   '+++++++++++++++++++++++++++++++++++++++
   Cells(3, "H").Resize(.Count) = Application.Transpose(.items)
   '++++++++++++++++++++++++++++++++++++++++
  
    End With
End Sub

 

[محي الدين ابو البشر]

أخي العزيز سليم

كلامك صحيح

مشكور

 

تم تعديل نوفمبر 3, 2019 بواسطه محي الدين ابو البشر

[أبو سـما]

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

 

يعجز لساني عن شكركم جميعاً جزاكم الله خيراً على ردودكم وسرعة استجابتكم للموضوع وجعلكم الله عوناً لنا وفي ميزان حسناتكم إن شاء الله . واسمحوا لي عند تطبيق الأكواد على الملف تبين لي بعض الملاحظات وهي كالتالي :

 

أولا : عند تطبيق كود الاخ " سليم حاصبياً " لا أدري هناك سمة خطأ فهي تعمل جيداً عند الصفوف الثلاث الأولى ويتم كتابة سنوات التكرار فعلاً ومن ثم تهمل بقية الصفوف.

 

ثانياً : عند تطبيق كود الأخ " محي الدين أبو البشر " بالفعل يعمل جيداً وتم التطبيق على كامل الملف وكما طلبت أنا بالفعل ولكني أغفلت ذكر أن التكرار مربوط بالرقم القومي وليس الاسم لأن الاسم ربما يكتب خطأ أو يكتب رباعي أو ثلاثي فجعلت الأساس هو الرقم القومي وليس الاسم عند كشف التكرار لأن الرقم القومي لا يتشابه لذا أرجو تعديل الكود ليتم كشف التكرار بالرقم القومي وليس الاسم.

 

وجزاكم الله خيرا 

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

تم التعديل كما تريد (كنت لا أريد ان تتكرر السنوات امام تكرار الاسماء )

Option Explicit

Sub extarct_recorde()
Dim dict As Object
Dim Sh As Worksheet, i%: i = 3
Dim Ky, k, itm

Set Sh = Sheets("ورقة1")
Set dict = CreateObject("Scripting.Dictionary")

With Sh
    .Range("H3").Resize(.Range("H3") _
    .CurrentRegion.Rows.Count).ClearContents
    
     Do Until .Range("C" & i) = vbNullString
        k = Sh.Range("C" & i): itm = Sh.Range("F" & i)
        If Not dict.exists(k) Then
            dict.Add k, itm
        Else
            dict(k) = dict(k) & "-" & itm
        End If
          i = i + 1
     Loop
        i = 3
     Do Until .Range("C" & i) = vbNullString
     .Range("H" & i) = dict(.Range("C" & i).Value)
     i = i + 1
     Loop

End With
Set dict = Nothing: Set Sh = Nothing
End Sub

 

[أبو سـما]

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

أخ سليم حاصبياَ اعذرني عند تطبيق الكود لم يعمل بالشكل المرجو فرجاءً انظر للمرفق فربما كان الخطأ من عندي وجزاك الله خير ا

أسمااء المشاركين.xlsm

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

الملف يعمل عل أكمل وجه

مرفق مع الكود

 

mosharikin.xlsm

[أبو سـما]

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

 

عذرا يا غالي لكن بعد تحميل الملف لوحظ مثلا في مسلسل رقم 2 مرات التكرار 3 ومكتوب سنتان فقط والمفترض أن يكتب 3 سنوات ومسلسل رقم 6 مرات التكرار 2 ومكتوب سنة واحدة فقط وغيرها الكثير ومن مسلسل 140 الكود غير مطبق ولا تظهر نتائج 

ارجو تحملنا وفي ميزان حسناتكم ان شاء الله

بعد تجربة هذا الكود للأخ محي الدين ابو البشر على الملف بالكامل تم بالفعل المطلوب الذي أريده وحفاظاً على وقتك الثمين يا غالي أرجو منك إذا أمكن التعديل عليه ليكون مربوط بالرقم المدني وليس بالاسم تلافياً للخطأ نظرا لجواز وجود العديد من الاخطاء عند التسجيل بالاسم فربما يكون الاسم ثلاثي او رباعي أو ينقص حرف او يزيد فلا يظهر التكرار وجزاك الله خيرا

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

العامود C  يحتوي على خلايا فارغة التي توقف الكود عن عمله 

مثلاً الخلية C143 

[أبو سـما]

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

 

صحيح كلامك يا غالي تم حذف الصف الفارغ والكود اصبح يعمل بكل سلاسة .

 

جزاك الله عنا خيرا وعذراً غلبتك معي أخي سليم حاصبياً ولا أنسى بالشكر الأخ محي الدين أبو البشر فقد قام بالمطلوب أيضاً ولكن بطريقة مختلفة بناءً على طلبي. 

[محي الدين ابو البشر]

Sub test()
    Dim a As Variant, lr, i
    lr = Cells(Rows.Count, 2).End(xlUp).Row
    a = Range("b3:b" & Cells(Rows.Count, 2).End(xlUp).Row).Resize(, 5)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> 0 Then
                If Not .exists(a(i, 1)) Then
                    .Add a(i, 1), a(i, 5)
                Else
                    .Item(a(i, 1)) = .Item(a(i, 1)) & "-" & a(i, 5)
                End If
            End If
        Next
        For i = 1 To lr - 2
            Cells(2 + i, 2).Offset(, 6) = .Item(Cells(2 + i, 2).Value)
        Next
    End With
End Sub

 

تم تعديل نوفمبر 6, 2019 بواسطه محي الدين ابو البشر