عمل الكنترول المدرسي ( ابدأ من حيث انتهى الآخرون )

[ahmed12345a]

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

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

في اي كنترول نحتاج صفحه رئيسيه لعمل بيانات المدرسه
من اسم المدرسه واسم الصف الذي سنتعامل معه والسنه الدراسيه واسماء كل من المدير ورئيس شئون الطلبه وغير ذلك
==
ونحتاج صفحه منفصله اخرى لبيانات الطلبه من ادراج الاسماء والنوع وحاله القيد وتاريخ الميلاد وغير ذلك من البيانات التي تخصهم
==
ونحتاج صفحه منفصله لادراج درجات التقويم او ( اعمال السنه ) في الترم الاول
==
ونحتاج صفحه منفصله اخرى لادراج درجات تحريري نصف العام
==
ومثل هاتين الصفحتين لاخر العام
بكده نكون انتهينا من المدخلات الصح
وعايزين المخرجات مثل الشهادات والاحصاءات وارقام الجلوس والاوائل
===
هذه مقدمه لابد منها
تابعونا يحفظكم الله

[ahmed12345a]

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

والصفحه التانيه وهي الاهم
لانها يجب ان يكون بها معطيات خاصه بالطلاب مثل اسم الطلاب والنوع وتاريخ الميلاد وحاله القيد وحساب السن في 1/10/2018 مثلا وحساب السن بيتم بالمعادلات
في هذه الحاله يجب ان يكون فيه كود خاص بالابجده يرتب الاولاد اولا ثم البنات
==
ولايوجد اي نشره خاصه بجعل البنات اولا
ونحتاج ايضا الى كود يجعل المعادلات الموجوده في في صف البدايه تنتقل الى الصفوف بعدد الطلبه فقط مهما كان عددهم
==
واكرر بعدد الطلبه فقط حتى يكون الملف خفيف وسريع
هنا يأتي سؤال واين الكود الذي يستطيع ان ينسخ المعادلات بعدد الطلاب ؟

[ahmed12345a]

'==================Option Explicit'هذا الكود للمحترم ياسر خليل' الهدف من الكود نسخ صفوف بالعدد في يدايات مختلفه من صفحات مختلفه'يعمل الكود بعد مسح بيانات الطلاب القديمه'يعمل الكود في بدايات صفوف مختلفه في صفحات متعدده'تم هذا الكود في   22/8/2017Sub Test_CopyRow_Procedure()  CopyRow "إدخال بيانات أساسية", 9    CopyRow "تقديرات  تحريرى أخر العام   ", 9    CopyRow "تقديرات  و درجات  نصف العام  ", 9    CopyRow "سلول 5", 6    CopyRow "نتيجة بالمجموع أخر", 9    CopyRow "نتيجة بالمجموع نصف", 9    CopyRow "نتيجة الطلبة أخر العام ", 9    CopyRow "تحريرى ف 1", 9    CopyRow "تحريرى ف 2", 9    CopyRow "نتيجة الطلبة نصف العام", 9    CopyRow "مراجعة درجات أخر العام ", 9    CopyRow "شيت  الرابع الرئيسى", 9    CopyRow " شيت نصف العام", 9    CopyRow "كشف تجميعى", 9  CopyRow "تقديرات  تحريرى نصف العام  ", 9  CopyRow " ملف  الأنشطة", 9  CopyRow " تقديرات و درجات أخر العام ", 9  CopyRow "تقديرات نصف العام ", 9  CopyRow " ملف الإنجاز فصل  2", 9    CopyRow " تقديرات أخر العام", 9 CopyRow " تقديرات أخر العام", 9  CopyRow " ملف الإنجاز ف 1", 9   ' CopyRow "إجمالى", 7    CopyRow "مراجعة درجات نصف العام", 9'استعادة خاصية اهتزاز الشاشة    Application.ScreenUpdating = True    Application.Calculation = xlCalculationAutomatic    Application.EnableEvents = True        'خليه وقوف المؤشر    'بعد الانتهاء من تنفيذ ادراج الصفوف    Application.GoTo _    Sheets("إدخال بيانات أساسية").Range("B10")    End SubSub CopyRow(sSheet As String, sRow As Long)    Dim ws      As Worksheet    Dim lr      As Long    Dim lc      As Long    Dim i       As Long    Application.ScreenUpdating = False    Application.Calculation = xlCalculationManual    Application.EnableEvents = False    'جملة لتجنب حدوث خطأ عند تعيين ورقة العمل    On Error Resume Next            Set ws = Sheets(sSheet)              'جملة لاستعادة خاصية تتبع الأخطاء    On Error GoTo 0    'إذا لم تكن هناك ورقة عمل بهذا الاسم    If ws Is Nothing Then     'تظهر رسالة تفيد بذلك ثم يتم الخروج من الإجراء الفرعي        MsgBox "ورقه " & sSheet & " غير موجوده.", vbExclamation, "ورقة غير موجودة!"        Exit Sub    End If    'مسح الصفوف    ws.Rows(sRow + 1).Resize(1000).Clear           'تعيين قيمة للمتغير ليساوي عدد الصفوف المقرر إدراجها في أوراق العمل    i = Sheets("إدخال بيانات أساسية") _    .Range("B7").Value - 1             ' عددالطلبة    lc = LastRowColumn(ws, "C")       'تحديد رقم آخر صف بورقة العمل المعنية مضافاً إليها 1 ليبدأ من أول صف جديد    lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1        On Error Resume Next            ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy            'لصق البيانات التي تم نسخها بداية من أول صف فارغ وبامتداد عدد الصفوف المقررة    ws.Range("A" & lr).Resize(i).PasteSpecial xlPasteAll              'مسح البيانات الثابتة فقط وليس المعادلات من النطاق الذي تم لصقه    ws.Range("A" & lr).Resize(i, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents   'سطر للذهاب لأول خلية في ورقة العمل بعد القيام بعملية النسخ    Application.GoTo ws.Range("A1")End SubFunction LastRowColumn(ws As Worksheet, rc As String) As Long    Dim lng     As Long    If Application.WorksheetFunction.CountA(ws.Cells) <> 0 Then        With ws            If UCase(rc) = "R" Then                lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row            ElseIf UCase(rc) = "C" Then                lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column            End If        End With    Else        lng = 1    End If    LastRowColumn = lngEnd Function

هذا هو الكود المتميز حقا
بارك الله في من اوجده
وبارك في كل من له بصمه في هذا

[ahmed12345a]

Sub التنقل_الى_الصفحات()    Application.CommandBars("Workbook Tabs").ShowPopup        Range("A1").SelectEnd Sub

هذا الكود يستطيع ان يوصلك الى اي صفحه تريدها بالملف

[ahmed12345a]

وهذا ملف خاص باصدار قديم للاستاذ احمد السيد .... ربنا يبارك فيه وفي امثاله
الاصدار السابع لايصلح الان لتنفيذ عمل الكنترول المدرسي لتغيير في درجاته
وانما اوجدته لتعرف كيف يتم التخفيف حجم البرنامج الاصلي 48 ميجا
واصبح الان حوالى ال 17ويمكن ان يخف لدرجه 4 او 5 ميجا مع عدم الاخلال باي صفحه
ولتستفيدوا من اكواده المتميزه
التغير تم في التابات الملونه بالاحمر مثل ارقام الجلوس ودقتها وروعتها
مثل كشوف المناداه وسرعتها
مثل الشهادات
وبالملف المزيد
رحمنا الله واياكم

[ahmed12345a]

الرقم السري لفتح الملف 111
ضع اي رقم في الخليه B7 في صفحه إدخال بيانات أساسية
وجرب زر نسخ صفوف بعدد الطلاب سيتم فورا مسح جميع البيانات القديمه واضافه صفوف بمعادلاتها بعدد الطلاب
==
ضع اي رقم في الخليه C7 في صفحه إدخال بيانات أساسية
وجرب زر نسخ صف لطالب محول سيتم فورا اضافه الصف او الصفين تحت الصفوف الموجوده .. جرب وشوف
==
اذهب الى كشوف المناداه بعد ملأ بيانات الطلاب واضغط على زر طباعه .. وشوف
==
اذهب الى صفحه فصول واضغط اولا على زر القيم الفريده لتاتي بفصول المدرسه ثم اختر من الخليه L1 اسم الفصل الذي تود طباعه اسماء ه ثم زر استدعاء وشوف الاسماء والسرعه والدقه ثم طباعه
==
اذهب الى صفحه شهاده نصف العام واضغط زر القيم الفريده
واملا ماتريده في الخلايا R1 .. S1 .. R7 ..S7 .. T7
ثم زر شهادات
رائعه
ادعو بالخير لكل من كانت له بصمه في هذا الملف ابتداء من الاستاذ احمد السيد

هذا هو الملف

https://up.top4top.net/downloadf-6756t2jc1-rar.html

[ahmed12345a]

هذا الكود خاص بالترحيل او الاستدعاء .
.. رائع بهذا الكود يكون اكتملت اكواد اي كنترول
يمكن عمله....
وحجمه ان شاء الله لايتخطى 4 ميجا ( ابدأ من حيث انتهى الاخرون )

'===========================
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو استدعاء بشرط
'تم هذا الكود في 15/2/2017
sub استدعاء()
dim arr as variant
dim temp as variant
dim cr as variant
dim lr as long
dim i as long
dim j as long
dim c as long
dim ws as worksheet
dim sh as worksheet
set ws = sheets("sheet1")
set sh = sheets("sheet2")
'= = = = = = = = = = = =
' شيت الهدف والمدى المطلوب مسحه
sh.range("b7:aj10000").clearcontents

' اسم ورقة المصدر
lr = ws.cells(rows.count, 1).end(xlup).row

'متغير اسم ورقة المصدرومدى البيانات بها
arr = ws.range("a7:ef" & lr).value

redim temp(1 to ubound(arr, 1), 1 to ubound(arr, 2))

'ارقام الاعمده المطلوب نقلها
cr = array(2, 3, 7, 8, 9, 11, 12, 24, 25, 35, 36, 46, 47, 57, 58, 72, 73)
j = 1

for i = lbound(arr, 1) to ubound(arr, 1)

' المعيار او الشرط الذي نبحث به ورقم عمود المعيار
if arr(i, 135) like "*" & "نا*" & "*" then
temp(j, 1) = j
for c = lbound(cr) to ubound(cr)
temp(j, c + 2) = arr(i, cr(c))
next c
j = j + 1
end if
next i

' اسم شيت الهدف
with sh
'====

'خليه بدايه اللصق في شيت الهدف
.range("b7").resize(j - 1, ubound(temp, 2)).value = temp

'سطر لمسح التسطير
.range("b7:aj" & rows.count).borders.value = 0

'سطر لاضافة التسطير
.range("b7:aj" & .cells(rows.count, 2).end(xlup).row).borders.value = 1
end with
end sub

[ahmed12345a]

رحمنا الله واياكم

[ahmed12345a]

رحمنا الله واياكم

[ahmed12345a]

رحمنا الله واياكم

[عبدالناصر الحلفاوى]

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

[ahmed12345a]

المشاركة الأصلية كتبت بواسطة عبدالناصر الحلفاوى

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

وبارك الله لك

[الحصيف]

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

[dopi]

ياريت الشرح فيديو او صور