قنديل الصياد

تم عمل الصفحة ومنتظرة لاستكمالها برفع النتيجة عليها

واليك رابط الصفحة

http://abusuliman.eb2a.com/natiga/index.htm

ان شاء الله وتحت امر حضرتك

مع تحياتى وتحيات الفريق الاعلامى بمنتديات اوفيسنا

يعنى النتيجة الموجودة على ملف الاكسيل دى مش مظبوطة

ساصمم لك الصفحة واترك النتيجة لحين اعلامى بها واكملها لحضرتك

سارفع لحضرتك النتيجة مؤقتا وساترك لك عنوانها هنا

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

اخى العزيز

راجع هذا الرابط

http://www.officena.net/ib/index.php?showtopic=54106&hl=

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

اخى العزيز ..

راجع هذا الرابط وان شاء الله يفيدك

http://www.officena.net/ib/index.php?showtopic=49351&hl=

اخى العزيز شكرا على الملف الجميل

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

قمت بإضافة هذا الكود فى ملف به درجات بعض الطلاب وعمل الكود بامتياز

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

فما الحل

مرفق الكود

Function TOPTEN(Mark_Table As Range, Cer_Table As Range, RNK As Integer, True_False As Boolean)
Application.ScreenUpdating = False
Dim Rw, i, k As Long
Dim CON As Integer
Dim HOS
Dim ARR
Dim SS
Dim M
Dim S
TOPTEN = "#N/A"
'-------------------------------------------------------------------
If True_False = True Then
ARR = Array("", "الأول", "الثاني", "الثالث", "الرابع" _
, "الخامس", "السادس", "السابع", "الثامن", "التاسع", "العاشر", "الحادى عشر", "الثانى عشر", "الثالث عشر", "الرايع عشر", "الخامس عشر", "السادس عشر", "السابع عشر", "الثامن عشر", "التاسع عشر", "العشرون", "الواحد والعشرون", "الثانى والعشرون", "الثالث والعشرون", "الرابع والعشرون", "الخامس العشرون", "السادس والعشرون", "السابع العشرون", "الثامن والعشرون", "التاسع والعشرون", "الثلاثون", "الواحد وثلاثون", "الثانى والثلاثون", "الثالث والثلاثون", "الرابع والثلاثون", "الخامس والثلاثون", "السادس والثلاثون", "السابع والثلاثون", "الثامن والثلاثون", "التاسع والثلاثون", "الأربعون", "الواحد وأربعون", "الثانى والأربعون", "الثالث والأربعون", "الرابع والأربعون", "الخامس والأربعون", "السادس والأربعون", "السابع والأربعون", "الثامن والأربعون", "التاسع والأربعون", "الخمسون ")
If WorksheetFunction.CountIf(Mark_Table, WorksheetFunction.Large(Mark_Table, RNK)) <> 1 Then
For i = 1 To RNK
If WorksheetFunction.Large(Mark_Table, RNK) = WorksheetFunction.Large(Mark_Table, i) Then Val1 = Val1 + 1
If Val1 = 2 Then
SS = " مكرر": RNK = i - 1: Exit For
End If
Next i
End If
10 TOPTEN = ARR(RNK) & SS
Exit Function
End If
'-------------------------------------------------------------------
For Rw = 1 To Mark_Table.Rows.Count
If WorksheetFunction.Large(Mark_Table, RNK) = Mark_Table.Cells(Rw, 1) Then
CON = WorksheetFunction.CountIf(Mark_Table, WorksheetFunction.Large(Mark_Table, RNK))
If CON = 0 Then
TOPTEN = Cer_Table.Cells(Rw, 1).TeCONt
Exit Function
End If
If CON <> 0 Then
M = M + 1: S = 0
For k = 1 To RNK
If WorksheetFunction.Large(Mark_Table, RNK) = WorksheetFunction.Large(Mark_Table, k) Then S = S + 1
Next k
If S = M Then
TOPTEN = Cer_Table.Cells(Rw, 1).Value
Exit Function
End If
End If
End If
Next Rw
Application.ScreenUpdating = True
End Function

شكرا اخى العزيز

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

شكرا جزيلا ... بارك الله فيك وعليك

يقوم الكود بحذف الخلايا المؤمنة ايضا بعد اضافة هذا السطر

ونريد ان لا تحذف المعادلات فى الخلايا المؤمنة

Sub صورة9_نقر()
  Application.ScreenUpdating = False
  sama = MsgBox("سيتم الغاء وحذف البيانات؟هل انت متأكد من اجراء هذه العملية", vbYesNo)
      If sama = vbYes Then
      Range("g11:am1000").ClearContents
      Else
      MsgBox "!! لم يتم الحذف"
      End If
  Sheets("مستويات اول نصف العام").Protect Password:="1900"
  Application.ScreenUpdating = True

End Sub

Range("g11:am1000").ClearContents

يظهر سطر النطاق بلون أصفر عند تنفيذ الكود بالرغم من استخدام الكود فى صفحات اخرى وتم تنفيذه بدون اى أخطاء

فما الخطأ فى الكود فى هذه الصفحة

مرفق ملف ونرجو اضافة كود

يعمل على اضافة صفوف تحت اخر صف وهو رقم 16 بنفس التنسيقات وبنفس المعادلات الموجودة فى الصف رقم 16  باى عدد نريد

2131.rar

الاستاذ العزيز / مختار حسين

ارفق الملف الذى وجد به الخطا وباذن الله نحاول اصلاحه

تحياتي

استاذنا القدير الاستاذ ياسر خليل

اليك ملف ومنفذ عليه الكود وكلمة سر الملف (1900)

درجات نصف العام.rar

شكرا جزيلا ابوصلاح

تم عمل المطلوب بنجاح

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

برجاء تعديل الكود لكى يعمل والصفحات تحت الحماية

Sub اضافة_حذف()
On Error Resume Next
Dim XX As Shape
Set XX = ActiveSheet.Shapes("الدائرة")
With XX.TextFrame.Characters
    If .Text = "إضافة الدوائر" Then
       Circles1
       .Text = "حذف الدوائر"
    Else
       RemoveCircles1
       .Text = "إضافة الدوائر"
    End If
End With
On Error GoTo 0
End Sub
Sub Circles1()
Dim C As Range
Dim MyRng As Range, V As Shape
Dim X As Integer, G As Integer, R As Integer, D As Integer
'================================================
G = 2       '    عمود رقم الجلوس
R = 11       '    صف الدرجات
Set MyRng = Range("j12:j56,n12:n56,aa12:aa56,ar12:ar56")  ' نطاق الخلايا الذي تريد اضافة الدوائر فيها
'================================================
X = ActiveWindow.Zoom
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100
For Each C In MyRng
    If Cells(C.Row, G) = 0 Then GoTo 1
    If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Value = "غ" Or C.Value = "غـ") Then
        Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 1, C.Top + 1, C.Width - 2, C.Height - 2)
        V.Fill.Visible = msoFalse
        V.Line.ForeColor.SchemeColor = 10
        V.Line.Weight = 1.25
        D = D + 1
    End If
1 Next
ActiveWindow.Zoom = X
Application.ScreenUpdating = True
MsgBox "تم إضافة   " & D & "   دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله"
End Sub
Sub RemoveCircles1()
    Dim shp As Shape, D As Integer
    For Each shp In ActiveSheet.Shapes
      If shp.AutoShapeType = msoShapeOval Then shp.Delete: D = D + 1
    Next shp
MsgBox "تم حذف   " & D & "   دائرة بنجاح", vbMsgBoxRtlReading, "الحمدلله"

End Sub

الاخ الكريم اين هى هذه الملفات

استاذى العزيز : الشهادات لاخر العام فقط

رابط تحميل الكنترول ويسع 200 طالب

كنترول تجريبي لغات  ايضا 2015

شكرا لكم جميعا

رابط به الكنترول لجميع الصفوف الابتدائية نسخة نهائية بعد اضافة بعض التعديلات ويسع 100 طالب لكل صف

درجات نصف العام يتم ترحيلها تلقائيا الى شيت آخر العام

تم زيادة اعداد التلاميذ بالكنترول ليسع 400 طالب فى الصفوف الرابع والخامس

و 300 طالب فى الصفوف الاول والثانى والثالث

شكرا جزيلا لكم أساتذتى الاحباء على كلماتكم الجميلة والرائعة ... بارك الله فيكم وعليكم وكل عام وحضراتكم بخير

كنترول المرحلة الابتدائية  للدورين معاً للعام الدراسي 2015/2014

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

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

اسم المستخدم للكنترول فى جميع الصفوف : الصياد

كلمة السر : 1964

كلمة السر لحماية الصفحات : 1900

يمكن زيادة الصفوف بعدد التلاميذ فى اى ملف بعد ادخال كلمة السر (1900) الموجودة لحماية الصفحات

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

رابط تحميل الكنترول على مخزن

تحميل الملف

قم بتعديل السنة كما هو موضح بالصورة التالية :