نجوم المشاركات

السلام عليكم ورحمة الله أخي الكريم، أستسمح أخي الحبيب أبو أحمد في القيام بتغيير في كوده الرائع حسب الطلب الجديد (الطالب الغائب) وفي الملف بالمعادلات تم إضافة هذا الشرط الجديد مع تسمية معادلة جلب علامة الطالب بالتسمية Formule لغرض اختصار المعادلة في الجدول... أخوكم بن علية ملف أخي الحبيب أبو أحمد بالكود: اسماء ودرجات الدور الثانى فقط لاغير.rar الملف بالمعادلات: اسماء ودرجات الدور الثانى فقط لاغير2.rar

السلام عليكم انتبهت الى ان الدرجة الصغرى ليست ثابته (25) هذا التعديل للكود السابق للاخذ بالاعتبار بالدرجة الصغرى استبدل الكود السابق في الملف بهذا Sub Abu_Ahmed_2nd() Dim cl As Range, cel As Range Set MySh = Sheets("Sheet1") [D8:I100].ClearContents For i = 4 To 28 ww = 0 For J = 1 To 5 t = Application.CountIf(MySh.Cells(i, J + 4), "<" & MySh.Cells(3, J + 4)) If t = 1 Then ww = ww + 1 Next If MySh.Cells(i, 2) = [L2] And MySh.Cells(i, 3) = [L3] And ww >= 1 And ww <= 2 Then Cells(Range("D1000").End(xlUp).Row + 1, 4) = MySh.Cells(i, 2).Offset(0, -1) For Each cel In MySh.Range(MySh.Cells(i, 5), MySh.Cells(i, 9)) If cel < MySh.Cells(3, cel.Column) And ww <= 2 Then Cells(Range("D1000").End(xlUp).Row, cel.Column) = cel Else: GoTo 2 End If 2 Next Else: GoTo 1 End If 1 Next Set MySh = Nothing End Sub