استخراج حالة الطالب ناجح او دور ثان ومواد الرسوب

بسم الله الرحمن الرحيم

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

وهو كود لاستخراج حالة الطالب  

ناجح او دور ثان اضافة لذلك مواد الرسوب 

الكود يحتاج الى تحديد الثوابت الموجودة بالكود  

وتم توضيح مكان التعديلات بالكود حسب توزيعات الملف 

الكود 

Sub YASSER_ELARABY()
'YASSER_ELARABY
'26-9-2016
    Dim ARR
    Dim ARRY
    Dim ARRYS
    Dim ALL_LESS As String
    Const STATUS As Byte = 101    'عمود الحالة ناجح او دور ثان
    Const NOTES As Byte = 102  ' عمود الملاحظات عمود المواد او منقول للصف ا لاخر
    Const GENDER As Byte = 112  ' عمود الجنس ذكر او انثى
    '_____________________________________________________
    Const LESS_ROW As Byte = 6  'صف الدرجة الصغرى
    Const NAM_ROW As Byte = 2    'صف اسماء المواد
    Const NAME_FIRST As Byte = 7  ' اول صف لاسماء الطلاب
    Const NAME_LAST As Long = 206 + NAME_FIRST  ' عدد الطلاب
    '_____________________________________________________
    ARR = Array(9, 18, 27, 36, 46, 52, 54, 59, 64, 69, 78)  ' اعمدة اختبار الفصل الدارسي الثاني  لجميع المواد
    ARRY = Array(13, 22, 31, 40, 51, 52, 57, 62, 67, 72, 82)  'اعمدة الدرجة النهائية لجميع المواد
    ARRYS = Array(5, 14, 23, 32, 41, 52, 53, 58, 63, 68, 74)  'اعمدة اسماء كل المواد
    '_____________________________________________________
    With Sheet2 'اسم الشيت الموجود به البيانات
    For R = NAME_FIRST To NAME_LAST
        For X = 0 To UBound(ARR)
            On Error Resume Next
            Application.ScreenUpdating = False
            If ARR(X) = 46 Then
                If Val(.Cells(R, ARR(X))) + Val(.Cells(R, ARR(X) + 1)) < Val(.Cells(LESS_ROW, ARR(X))) Or .Cells(R, ARR(X)) = "غ" Or .Cells(R, ARR(X) + 1) = "غ" Then
                    ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "
                    GoTo 86
                Else
                    GoTo 86
                End If
            End If
            If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Or .Cells(R, ARR(X)) = "غ" _
               Or .Cells(R, ARRY(X)) < .Cells(LESS_ROW, ARRY(X)) Or .Cells(R, ARRY(X)) = "غ" Then
                ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "
            End If
86      Next X
        '_____________________________________________________

        If ALL_LESS = "" Then
            If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "ناجح "
            If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "ناجحة "
            If .Cells(R, GENDER) = 1 Then .Cells(R, 102) = "ومنقول " & INFO.Range("B14")
            If .Cells(R, GENDER) = 2 Then .Cells(R, 102) = "ومنقولة " & INFO.Range("B14")
        ElseIf ALL_LESS <> "" Then
            If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "له دور ثان في"
            If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "لها دور ثان في"
            .Cells(R, 102) = Left(ALL_LESS, Len(ALL_LESS) - 2)
            ALL_LESS = Empty
        End If
    Next R
    End With
    Application.ScreenUpdating = True
End Sub

كما هو موضح اماكن التعديل بالكود

لتحميل الملف اضغط هنا

تعديل اخر للكود ليتماشى مع نظام المدارس اكثر 

التعديل يشمل الرسوب باقل من ثلث الدرجة للفصل الدراسي الثاني 

واذا تغيب الطالب في كل المواد او مجموع كل المواد صفر يصبح الطالب غائب 

الكود

 Sub YASSER_ELARABY()  
 'YASSER_ELARABY  
   Dim ARR  
   Dim ARRY  
   Dim ARRYS  
   '___________________________________________  
   Dim R As Long  
   Dim X As Long  
   Dim XX As Byte  
   Dim ALL_LESS As String  
   '___________________________________________  
   Const STATUS As Byte = 101  'عمود الحالة ناجح او دور ثان  
   Const NOTES As Byte = 102 ' عمود الملاحظات عمود المواد او منقول للصف ا لاخر  
   Const GENDER As Byte = 112 ' عمود الجنس ذكر او انثى  
   '_____________________________________________________  
   Const LESS_ROW As Byte = 6 'صف الدرجة الصغرى  
   Const NAM_ROW As Byte = 2  'صف اسماء المواد  
   Const NAME_FIRST As Byte = 7 ' اول صف لاسماء الطلاب  
   Const NAME_LAST As Long = 206 + NAME_FIRST ' عدد الطلاب  
   '_____________________________________________________  
   ARR = Array(9, 18, 27, 36, 46, 52, 54, 59, 64, 69, 78) ' اعمدة اختبار الفصل الدارسي الثاني لجميع المواد  
   ARRY = Array(13, 22, 31, 40, 51, 52, 57, 62, 67, 72, 82) 'اعمدة الدرجة النهائية لجميع المواد  
   ARRYS = Array(5, 14, 23, 32, 41, 52, 53, 58, 63, 68, 74) 'اعمدة اسماء كل المواد  
   '_____________________________________________________  
   With Sheet2  'اسم شيت البيانات  
     Application.ScreenUpdating = False  'الغاء تحديث الشاشة  
     Application.Calculation = xlManual  ' ايقاف الحساب التلقائي  
     For R = NAME_FIRST To NAME_LAST  ' حلقة تكرارية تبدأ بأول اسم طالب الى اخر اسم  
       For X = 0 To UBound(ARR)  ' حلقة تكرارية تبدأ من الصفر الى اقصى مصفوفة اعمدة اختبار الفصل الدارسي الثاني  
         On Error Resume Next  
         '____________________________________________________  
         'يتم حساب عدد ا لمواد المتغيب بها الطالب او درجتها صفر ويتم وضع عدد المواد في المتغير اكس اكس  
         'اذا وصل عدد المواد الى 11 اصبح الطالب متغيب  
         If .Cells(R, ARRY(X)) = 0 Or .Cells(R, ARRY(X)) = "غ" Then  
           XX = XX + 1  
         End If  
         '____________________________________________________  
         'هذا الجزء خاص بمادة العلوم تحديدا الفصل الدراسي الثاني لانه مقسم على عمودين فتم اضافة هذا الجزء ليتم معالجة هذه المرحلة  
         If ARR(X) = 46 Then  
           'لايوجد اختلاف بين هذا الكود وبين الكود الموجود بالاسفل  
           If Val(.Cells(R, ARR(X))) + Val(.Cells(R, ARR(X) + 1)) < Val(.Cells(LESS_ROW, ARR(X))) Or .Cells(R, ARR(X)) = "غ" Or .Cells(R, ARR(X) + 1) = "غ" Then  
             ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": GoTo 86  
             GoTo 86 'هنا يتم تخطى عمل الكود بالاسفل حتى لايتم معالجة مادة العلوم مرة اخرى  
           Else  
             GoTo 86 'وهنا ايضا يتم تخطى مادة العلوم الى المادة الاخرى  
           End If  
         End If  
         'هنا يتم مقارنة المواد بالدرجة الصغرى الخاصة الفصل الدارسي الثاني في اول الكود او اذا كانت غياب يتم اضافة اسم المادة من صف المواد الى المتغير  
         'ALL_LESS  
         'او مقارنة الدرجة النهائية لكل مادة بالدرجة الصغرى لها او اذا كانت غياب اذا تحقق الشرط فيتم اضافة المادة الى المتغير  
         'ALL_LESS  
         '______________________________________________________  
         If .Cells(R, ARR(X)) < .Cells(LESS_ROW, ARR(X)) Or .Cells(R, ARR(X)) = "غ" Then  
           ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " لثلث الدرجة " & " - ": GoTo 86  
         End If  
         If .Cells(R, ARRY(X)) < .Cells(LESS_ROW, ARRY(X)) Or .Cells(R, ARRY(X)) = "غ" Then  
           ALL_LESS = ALL_LESS & .Cells(NAM_ROW, ARRYS(X)) & " - "  
         End If  
         '______________________________________________________  
 86     Next X  'الذهاب الى المادة الاخرى لاعادة تطبيق الكود مرة اخرى حتى انتهاء جميع المواد  
       'اذا كان المتغير اكس اكس بيساوي عدد المواد اذن الطالب متغيب  
       If XX = 11 Then ALL_LESS = "غياب ": XX = 0  
       '_____________________________________________________  
       'هنا بعد اكتمال الكود يتم عمل شرط للمتغير  
       'ALL_LESS  
       'اذا كان المتغير فارغ اي لم يتم اضافة اي مواد به اذا الطالب ناجح  
       If ALL_LESS = "" Then  
         If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "ناجح "  'اذا كان نوع الطالب ذكر يتم وضع ناجح  
         If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "ناجحة "  'اذا كانت انثى يتم وضع ناجحه  
         If .Cells(R, GENDER) = 1 Then .Cells(R, NOTES) = "ومنقول " & INFO.Range("B14")  'ويتم وضع في الملاحظات منقول الى ويتم جلب الصف من صفحة الانفو  
         If .Cells(R, GENDER) = 2 Then .Cells(R, NOTES) = "ومنقولة " & INFO.Range("B14")  'مثل ماسبق  
         'اما اذا كان المتغير يحمل اي بيانات لمواد يصبح الطالب له دور ثان  
       ElseIf ALL_LESS <> "" Then  
         If .Cells(R, GENDER) = 1 Then .Cells(R, STATUS) = "له دور ثان في"  'مثل ما سبق بخصوص النوع  
         If .Cells(R, GENDER) = 2 Then .Cells(R, STATUS) = "لها دور ثان في"  '  
         .Cells(R, NOTES) = Left(ALL_LESS, Len(ALL_LESS) - 2)  'هنا يتم وضع قيمة المتغير اي المواد في خلية الملاحظات  
         ALL_LESS = Empty  'تفريغ المتغير لاعادة تعبئة اسم طالب اخر  
       End If  
       '_____________________________________________________  
     Next R  'الذهاب الى الصف التالي حتى انتهاء عدد الطلاب  
   End With  
   Application.ScreenUpdating = True  'اعادة تحديث الشاشة  
   Application.Calculation = xlAutomatic  'تشغيل الحساب التلقائي  
 End Sub  

لتحميل الملف اضغط هنا

اعداد / ياسر العربي

انتحار جماعي لكل ملفات الاكسيل في مسار معين حسب شرط معين

بسم الله الرحمن الرحيم

اولا اعوذ بالله من كلمة انتحار دي ولكن اهو مجرد عنوان رنان

ثانيا

نضع لكم كود لحذف جميع ملفات الاكسيل من مسار معين عند فتح ملف اكسيل وتحقق الشرط المحدد

الكود في حدث فتح المصنف

 Sub Clear_All_Files_And_SubFolders_In_Folder()  
 Dim FSO As Object  
 Dim MyPath As String  
 If Date > DateValue("15/9/2016") Then  
 Set FSO = CreateObject("scripting.filesystemobject")  
 MyPath = "D:\Yasser" '<<مسارالملفات والفولدرات المرادمسحهم  
 If Right(MyPath, 1) = "\" Then  
 MyPath = Left(MyPath, Len(MyPath) - 1)  
 End If  
 If FSO.FolderExists(MyPath) = False Then  
 'MsgBox MyPath & " doesn't exist"  
 Exit Sub  
 End If  
 On Error Resume Next  
 FSO.deletefile MyPath & "\*.xl*", True 'مسح ملفات الاكسيل اذاكانت تريد مسح جميع الملفات ضع * بدلا من الاكسيل  
 ' FSO.deletefolder MyPath & "\*.*", True' اذا كنت تريدمسح كل الفولدرات الموجودة داخل المسار المحدد  
 On Error GoTo 0  
 End If  
 End Sub 0

كل ما عليكم هو التعديل على المسارات المطلوبة

لتحميل الملف من هنا

ومن الممكن حذف اي ملفات اخرى غير الاكسيل فقط يتم تحديد امتداد الملفات بالكود 

وشكرا

انتحار ملف الإكسيل Kill Workbook From HD لابو البراء

بسم الله الرحمن الرحيم


KILL Workbook

اثراء لموضوع اخي الكريم ابو البراء قمت بتعديل الكود لمعرفة رقم الهارد الفزيكال

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

 Function GetPhysicalSerial() As Variant  
   Dim obj As Object  
   Dim WMI As Object  
   Dim SNList() As String, i As Long, Count As Long  
   Set WMI = GetObject("WinMgmts:")  
   For Each obj In WMI.InstancesOf("Win32_PhysicalMedia")  
     If obj.SerialNumber <> "" Then Count = Count + 1  
   Next  
   ReDim SNList(1 To Count, 1 To 1)  
   i = 1  
   For Each obj In WMI.InstancesOf("Win32_PhysicalMedia")  
     SNList(i, 1) = obj.SerialNumber  
     i = i + 1  
     If i > Count Then Exit For  
   Next  
   GetPhysicalSerial = SNList  
 End Function  

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

 Private Sub Workbook_Open()  
   Range("A1") = GetPhysicalSerial  
   If Range("A1") <> "31534756394a5a41304237333634202020202020" Then 'هنا نضع رقم الهارد الفيزيكال  
     With ThisWorkbook  
       .Save  
       .ChangeFileAccess Mode:=xlReadOnly  
       Kill .FullName  
       .Close SaveChanges:=False  
     End With  
   End If  
 End Sub  

لتحميل الملف من هنا

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

مع مراعاة تغيير رقم السيريال

في اول الامر نقوم بازالة اول علامة فقط ونحفظ الملف ونفتحه مرة اخرى سيظهر لنا رقم الهارد في الخلية A1

نقوم بنسخه الى الكود مكان الرقم الاخر ونقوم بازالة كل العلامات من امام الكود

وشكرا