ارجو المساعدة بكود إحصاء مواد الدور الثانى ( عنوان معدل )

[فضل حسين]

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

الى خبراء واعضاء منتداى العزيز والعظيم

ارجو المساعدة بكود 

مرفق ملف موضح به المطلوب

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

مساعدة بكود.rar

[رجب جاويش]

السلام عليكم

أخى الحبيب / فضل

تفض أخى

Sub ragab()
Dim cl As Range
Dim i As Integer
Dim x As Integer
Dim LR As Integer
Set Rng = Range("C2:C42")
Application.ScreenUpdating = False
Range("E3:V42").ClearContents
For i = 6 To 22 Step 2
    For Each cl In Rng
        x = Application.WorksheetFunction.CountIf(cl, "*" & Cells(2, i) & "*")
        If x >= 1 Then
            LR = Cells(Rows.Count, i).End(xlUp).Row + 1
            Cells(LR, i) = cl.Offset(0, -2)
            Cells(LR, i - 1) = cl.Offset(0, -1)
        End If
    Next
Next i
Application.ScreenUpdating = True
End Sub

مساعدة بكود.rar

[رجب جاويش]

أخى الحبيب / فضل

سوف يتم تغيير العنوان ليناسب محتوى الموضوع

[إبراهيم ابوليله]

اخى واستاذنا رجب

اسمح لى ارفع لك القبعه

بالفعل انت تثبت لنا انه لا نهايه فى العلم

بارك الله فيك

اعمالك فى غايه الجمال

والبساطه

ذادك الله من فضله وعلمه

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

استاذ فضل /

الموضوع ليس بحاجة الى كود فقد تم حله بواسطة بضعة معادلات

الحل مرفق

1مساعدة بكود.rar

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

الاستاذ رجب المحترم

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

[رجب جاويش]

أخى الحبيب / ابراهيم

جزاك الله كل خير أخى الحبيب على هذه الكلمات الطيبة

تقبل أرق تحياتى

[رجب جاويش]

أخى الفاضل / سليم

ولا يهمك أخى الفاضل

إنما هى زيادة فى الخير

وتنوع للحلول

تقبل أرق تحياتى

[فضل حسين]

استاذنا الفاضل الكبير/ رجب جاويش 

تسلم الايادى والعقول النيرة التى سطرت هذا الكود الجميل مثلك

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

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

فأنت شخصية جميلة نتعلم منك العلم والذوق والاخلاق العالية والشياكة والجمال

 ربنا يخليك لنا وللمنتدى ودعواتى لك بأجمل المنى وارق التهانى

 

[رجب جاويش]

أخى الحبيب / فضل

شكرا جزيلا أخى الحبيب على هذه الكلمات الطيبة

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