مجاميع ونتائج بشروط متغيرة وبدون تكرار

[غالب عبد]

السلام عليكم ورحمة الله تعالى وبركاته
اخوتي الكرام 
جزاكم الله عنا كل خير 

ارجو المساعدة في استكمال كود او صيغة الجمع واستدعاء البيانات في هذا الملف المرفق 

وقد تم عمل كود لصفحة (توقفات) لإستدعاء البيانات بالشروط الموضحة في الصفحة الكن صادفتني مشكلة جمع قيم البيانات المكررة  

وهي على الشكل التالي:

 

 

عند اختيار الآلة من المدى C14:C30 يقوم البرنامج بتحديد خلايا باللون الأحمر في المدى D14:D30 وهي مجموع الأعطال السنوية للآلة المختارة و في المدى G17:G28 هي مجموع الأعطال الشهرية للآلة المختارة وفي المدى K8:K38 هي مجموع الأعطال اليومية للآلة المختارة وفي المدى M8:O38 تفاصيل الأعطال اليومية للآلة المختارة بعد تحديدها من المدى K8:K38
والمطلوب اخواني : جلب مجاميع وتفاصيل سبب الأعطال لهذه الأزمنة لكل آلة مختارة بدون تكرار علماً انه قد تم عمل كود لجلب هذه البيانات في صفة تصفية لكن كانت المشكلة بجمع تكرارية ازمنة الأعطال

 

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

مجماميع يشروط وبدون تكرار.rar

[غالب عبد]

للرفع
جزاكم الله كل خير

[غالب عبد]

جزاكم الله عنا كل خير

للرفع

[غالب عبد]

الأخوة الأفاضل 
افيدونا جزاكم الله عنا كل خير

[غالب عبد]

للرفع

اخوتي في الله

[غالب عبد]

للرفع
جزاكم الله كل خير

[غالب عبد]

اخواني الكرام 
للرفع
هل الشرح مع المرفق وافي ام المطلوب صعب 
افيدونا اخواني الكرام جزاكم الله عنا كل خير

[غالب عبد]

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

[غالب عبد]

الأخوة الأفاضل 
افيدونا جزاكم الله عنا كل خير

[الخالدي]

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

حسب مافهمت من المطلوب جرب الكود المرفق

الكود يعمل على اكسل2007 وما فوق ويعتمد على تاريخ الشهر في الخلية A2 بدلا من الخلية B2

Sub AL_KHALEDI()
With Sheets("بيانات")
Set Rng = Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp)(1, 49))
End With
Col = Application.Match([A1], Rng.Rows(0), 0)
ReDim Arr(1 To 3, 1 To 3)
For r = 1 To Rng.Rows.Count
If Rng(r, Col) <> "" And Rng(r, 1) = [A2] Then
If Application.CountIfs(Rng(1, 2).Resize(r), Rng(r, 2), Rng(1, 5).Resize(r), Rng(r, 5), Rng(1, 6).Resize(r), Rng(r, 6)) = 1 Then
W = Application.Match(Rng(r, 5), [{"الخط الأول","الخط الثاني","الخط الثالث"}], 0)
H = Application.Match(Rng(r, 6), [{"الوردية الصباحية","الوردية المسائية","الوردية الليلية"}], 0)
If Not IsError(W) And Not IsError(H) Then
Arr(W, H) = Arr(W, H) + Rng(r, Col).Value
End If: End If: End If
Next r
For Each C In [M8:O8,M18:O18,M28:O28]
C.Value = Arr(A Mod 3 + 1, Int(A / 3) + 1) + 0
A = A + 1
Next C
Erase Arr
MsgBox "تم بحمد الله"
End Sub

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

في امان الله

مجاميع بشروط وبدون تكرار2007.rar

[غالب عبد]

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

 

الأستاذ / الخالدي المحترم

 

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

 

تحياتي لك ولمجهودك وسأظل اتواصل معك إن شاء الله

 

استاذي الكريم الكود اكثر من رائع وحصلت من خلاله على مجاميع الأزمنة 

لكن استاذي الكريم في المدى M8:O38  اريد سبب الأعطال اليومية للآلة المختارة بعد تحديدها من المدى K8:K38 
بمعنى : اذا حددت يوم معين في المدى I8:I38 يعطيني سبب العطل في المدى M8:O38 بحسب الخط والوردية

 

بإنتظار ردكم الكريم

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

[الخالدي]

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

جزاك الله خيرا واحسن اليك ولك مثل دعائك لي  اخي الكريم

جرب التعديل التالي للكود

Sub AL_KHALEDI()
With Sheets("بيانات")
Set Rng = Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp)(1, 49))
End With
Col = Application.Match([A1], Rng.Rows(0), 0) + 1
ReDim Arr(1 To 3, 1 To 3)
For r = 1 To Rng.Rows.Count
If Rng(r, Col) <> "" And Rng(r, 2) = [A3] Then
If Application.CountIfs( _
      Rng(1, 2).Resize(r), Rng(r, 2), _
      Rng(1, 5).Resize(r), Rng(r, 5), _
      Rng(1, 6).Resize(r), Rng(r, 6), _
      Rng(1, Col).Resize(r), Rng(r, Col)) = 1 Then
W = Application.Match(Rng(r, 5), [{"الخط الأول","الخط الثاني","الخط الثالث"}], 0)
H = Application.Match(Rng(r, 6), [{"الوردية الصباحية","الوردية المسائية","الوردية الليلية"}], 0)
If Not IsError(W) And Not IsError(H) Then
Arr(W, H) = Arr(W, H) & Rng(r, Col).Value & Chr(10)
End If: End If: End If
Next r
For Each C In [M8:O8,M18:O18,M28:O28]
C.Value = ""
L = Len(Arr(A Mod 3 + 1, Int(A / 3) + 1))
If L Then C.Value = Mid(Arr(A Mod 3 + 1, Int(A / 3) + 1), 1, L - 1)
A = A + 1
Next C
Set Rng = Nothing: Erase Arr
MsgBox "تم بحمد الله"
End Sub

[غالب عبد]

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

 

الأستاذ / الخالدي المحترم

 

الكود لوحة فنية %

وهو المطلوب

 

زادك الله علما وشرفا واعلى مقامكم في الدارين وصدقا لا يسعني إلا أن أقول ما شاء الله تبارك الله 

 وبارك الله لك في أهلك وولدك ومالك ووفقك الله وسدد خطاك ونفع بك وبعلمك 

وجزاك الله كل خيرعلى صدق النية في خدمة الأخوة في المنتدى

 

فمهما كان الوصف لن أوفيك حقك...

 

لك  مودتي واحترامي