التعديل على ملف الاستاذ احمد بدره

[محمد7788]

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

قوائم (1).xls

[ابراهيم الحداد]

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

استخدم هذا الكود

Sub DistStudents()
Dim ws As Worksheet, Sh As Worksheet
Dim C As Range
Dim p As Long
Dim A As Variant, B As Variant
Set ws = Sheets("قائمة")
Set Sh = Sheets("تسجيل البيانات")
A = ws.Range("I2")
B = ws.Range("J2")
x = Sh.Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
ws.Range("A8:H47").ClearContents

For Each C In Sh.Range("E2:E" & x)
If C.Value = A And C.Offset(0, 1) = B Then
p = p + 1
If p <= 40 Then
ws.Cells(p + 7, 1) = p
ws.Cells(p + 7, 2) = C.Offset(0, -3).Value
ws.Cells(p + 7, 3) = C.Offset(0, -2).Value
ws.Cells(p + 7, 4) = C.Offset(0, -1).Value

ElseIf p > 40 Then
ws.Cells(p - 33, 5) = p
ws.Cells(p - 33, 6) = C.Offset(0, -3).Value
ws.Cells(p - 33, 7) = C.Offset(0, -2).Value
ws.Cells(p - 33, 8) = C.Offset(0, -1).Value

End If
End If
Next
Application.ScreenUpdating = True

End Sub

 

[احمد بدره]

أتوجه بالشكر لأستاذنا الفاضل إبراهيم الحداد على مروره  وبعد إذنه

تم التعديل على كوده وأصبح يعمل بصورة ممتازة

قوائم (1).xls

[محمد7788]

 

شاكر جدا لاهتمام حضراتكم  وسلمت يدك استاذ احمد بدره

                                                                                                 Set ws = Sheets("قائمة")

[عطية23]

هناك تعديل بسيط فيقوائم (1).xls معادلات الاحصاء ارجو تقبل الاضافة 

[احمد بدره]

تم تعديل المعادلات

قوائم (1).xls