عمل كشف ملخص من بيانات

[مستخدم الاوفس]

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

لدي قاب من البيانات يحتوي على الاعمده 

رمز الموظف 

الاسم

التاريخ 

الملاحظات

هذه البيانات تتكرر لنفس الشخص حسب عدد ايام كل شهر 

ولكن الملاحظة تختلف 

انا بحاجة الى جلب نوع محدد من الملاحظات حسب  تاريخ الملاحظة  ووضعها في جدول بعد ازالة التكرار وترتيب الملاحظات حسب تاريخها فقط الملاحظات المطلوبة وترتيبها بواحدة بعد الاخرى بينهم علامه &

باستخدام الكود يعني vba وليس الدوال وفقكم الله 

الشرح وافي في المرفق 

وشكراً

 

 

مثال.xlsx

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

جرب هذا الماكرو

Option Explicit
Sub get_moulahaza()
  Dim Dic_Name As Object
  Dim Dic As Object
  Dim i%, Ro%, ky
Ro = Cells(Rows.Count, 2).End(3).Row
Range("j4").CurrentRegion.Offset(2, 1).ClearContents
Set Dic_Name = CreateObject("Scripting.Dictionary")
Set Dic = CreateObject("Scripting.Dictionary")
'=============================
 For i = 2 To Ro
  Dic_Name(Cells(i, 2).Value) = vbNullString
 Next
'=============================
For Each ky In Dic_Name.Keys
    For i = 2 To Ro
        If Cells(i, 4) <> "حاضر" And Cells(i, 2) = ky Then
            If Not Dic.Exists(Cells(i, 2).Value) Then
              Dic.Add Cells(i, 2).Value, _
              Cells(i, 4) & " " & Cells(i, 3)
            Else
             Dic(Cells(i, 2).Value) = _
             Dic(Cells(i, 2).Value) & " * " & _
             Cells(i, 4).Value & " " & Cells(i, 3)
            End If
        End If
    Next i
 Next ky
  With Dic
    Cells(4, "K").Resize(.Count) = _
      Application.Transpose(.Keys)
    Cells(4, "L").Resize(.Count) = _
      Application.Transpose(.Items)
  End With
 Set Dic_Name = Nothing: Set Dic = Nothing
End Sub

الملف مرفق مع الكود

 

Exampl_moulahaza.xlsm

[مستخدم الاوفس]

وفقك الله لكل خير اخي العزيز 

لكن الموضوع بحاجة الى بعض العديلات بداية 

انا اريد التصفية تكون ليس على اساس الاسم فقط وانما الاسم ورمز الموظف 

اي بتعبير اخر ان تكون الخلاصة يحوي ايضاً على رمز الموظف كون من الممكن ان يتكرر الاسم لكن الرمز للموظف لايمكن ان يتكرر

اي يكون العمل ليس على اساس الاسم وانما تكون العملية على اساس رمز الموظف

وفقك الله لكل خير

تم تعديل نوفمبر 22, 2019 بواسطه مستخدم الاوفس

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

أمر بسيط جداً  بواسطة التعديل على الماكرو

في الاسطر مابين علامات الـــ+ ++++

ليبدو الماكرو هكذا 

Option Explicit
Sub get_moulahaza()
  Dim Dic_Name As Object
  Dim Dic As Object
  Dim i%, Ro%, ky
Ro = Cells(Rows.Count, 2).End(3).Row
'+++++++++++++++++++++++++++++++++++++++++
Range("j4").CurrentRegion.Offset(2).ClearContents
'+++++++++++++++++++++++++++++++++++++++++

Set Dic_Name = CreateObject("Scripting.Dictionary")
Set Dic = CreateObject("Scripting.Dictionary")
'=============================
'++++++++++++++++++++++++++++++++++
 For i = 2 To Ro
  Dic_Name(Cells(i, 2).Value) = Cells(i, 1).Value
 Next
'++++++++++++++++++++++++++++++++++
'=============================
For Each ky In Dic_Name.Keys
    For i = 2 To Ro
        If Cells(i, 4) <> "حاضر" And Cells(i, 2) = ky Then
            If Not Dic.Exists(Cells(i, 2).Value) Then
              Dic.Add Cells(i, 2).Value, _
              Cells(i, 4) & " " & Cells(i, 3)
            Else
             Dic(Cells(i, 2).Value) = _
             Dic(Cells(i, 2).Value) & " * " & _
             Cells(i, 4).Value & " " & Cells(i, 3)
            End If
        End If
    Next i
 Next ky
  With Dic
    Cells(4, "K").Resize(.Count) = _
      Application.Transpose(.Keys)
    Cells(4, "L").Resize(.Count) = _
      Application.Transpose(.items)
  End With
  '++++++++++++++++++++++++++++++++++++++++++
  Cells(4, "J").Resize(Dic_Name.Count) = _
  Application.Transpose(Dic_Name.items)
  '++++++++++++++++++++++++++++++++++++++++++
 Set Dic_Name = Nothing: Set Dic = Nothing
End Sub

الملف من جديد

 

Exampl_moulahaza_new.xlsm

[مستخدم الاوفس]

وفقك الله لكل خير وشكراً جزيلا

جار التحقق من الحل 

الف شكر اخي

اخل العزيز هل من الممكن ان نضيف فكرة بسيطة 

وهي في خالة ان تتكرر الملاحظة مثلاً غياب 1/1/2019 وغياب 2/1/2019 وغياب 3/1/2019

هل من الممكن ان تكون في الملخص بالصورة التالية غياب 1/1/2019 لغاية 3/1/2019

 

هذا ليس فقط للغياب وانما ايضاً باقي الملاحظات الاخرى كذلك 

 

وفقك الله لكل خير 

[S0bhy]

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

اخى انا عندى حل اتمنى انه ممكن يفيدك

ممكن تستخدم ال Pivotable            على انه يطلعلك ريبورت

زى ما فى المرفقات

,وطبعا انت بتقدر تتحكم فى الصفوف وال العوامميد الى انت بتحتاجها وبتطلع على اساسها الريبورت

,وهنا هتلاقى شرح لطريقة عمل البيفوت تابل 

واتمنى انى اكون افدتك

 

Exampl_moulahaza.xlsm

تم تعديل نوفمبر 23, 2019 بواسطه S0bhy
توضيح اكثر بالشرح

[مستخدم الاوفس]

شكراً جزيلاً اكيد افدتني

[أحمد يوسف]

أستاذ

مستخدم الاوفس

 

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

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

[مستخدم الاوفس]

السلام عليكم اخي . ممكن تشرحلي هذه الأسطر:

Else
             Dic(Cells(i, 2).Value) = _
             Dic(Cells(i, 2).Value) & " * " & _
             Cells(i, 4).Value & " " & Cells(i, 3)
            End If

هذه الاضافة في حال وجد الاسم نفسه ، هل الاضافة في dic  تكون على ال key ام على item. ام على الاثنان ؟ واذا كانت على الitem فكيف تحدد ذلك؟ حيث اني ارى ان الاسم يضاف في كل مرة بالإضافة الى الحالة و التاريخ ، هل هذا صحيح؟ ارجو التوضيح .