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

[هادي أحمد]

لدي ملف به أكثر من شيت المطلوب

 1 - المطلوب

         عند كتابة راسب يتم عمل كشف باسماء الطلبة الراسبين من الشيتات الموجودة مع مراعاة امكانية زيادة الاسماء في كل شيت وزيادة عدد الشيتات ( 3 - 5 ) و ( 3 - 6 ) وهكذا في حالة الطلبة الناجحين أو دور ثاني

 

2 - المطلوب

         عند الضغط علي اي زر يتم طباعة الكشف الموجود في الهايبر لينك سواء كانت طابعة او pdf

 

للشرح أكثر الرجاء فتح الملف

 

 

 

 

م.rar

[الشهابي]

أخي العزيز  / هادي أحمد 

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

جرب المرفق التالي 

فيه المطلوب الأول 

والمطلوب الثاني للطباعة فقط 

م.rar

[هادي أحمد]

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

 ولو اردت اضافة حالة اخري كمفصول أو غياب او اي شئ ماذا افعل

ولو فيه طريقة بالدوال لو سمحت

تم تعديل فبراير 8, 2017 بواسطه هادي أحمد

[الشهابي]

أخي العزيز  / هادي أحمد 

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

هذا شرح للكود

Sub استدعاء()
          Application.ScreenUpdating = False 'إيقاف اهتزاز الشاشة أثناء تنفيد الكود
          Application.EnableEvents = False 'منع تنفيذ أي حدث آخر
          Application.Calculation = xlManual 'تحويل الحساب إلى يدوي
          'الغرض من الأسطر السابقة هو تسريع عمل الكود
                    
        'On Error Resume Next هذا من أجل الاستمرار في حالة حدوث خطأ ولكن لم يستخدم
      Sheets(2).Range("A8:n1000").EntireRow.Delete 'حذف الصفوف في المدى المحدد في الورقة الثانية ورقة ( الدرجات )
     For i = 3 To ActiveWorkbook.Sheets.Count 'عمل حلقة تكرارية لأوراق الملف من الورقة الثالثة حتى آخر ورقة
    lr = Sheets(i).Range("B10000").End(xlUp).Row 'تحديد آخر صف به بيانات في أرواق الحلقة التكرارية الممثلة بالمتغير ( i )
    lr1 = Sheets(2).Range("B10000").End(xlUp).Row + 1 'تحديد آخر صف فارغ في ورقة الدرجات

    
    Sheets(i).Range("n7:n" & lr).ClearContents 'مسح البيانات في المدى المحدد في في أرواق الحلقة التكرارية
    Sheets(i).Range("n6").Value = "الصف"  'كتابة كلمة الصف في الخلية (n6) من أجل إضافة عمود يحمل اسم الروقة في جميع أوراقة الحلقةالتكرارية
    With Sheets(i).Range("n7:n" & lr) 'تحديد المدى المحدد
    .NumberFormat = "@" 'جعل المدى نوع الإدخال فيه ( نص )
    .Value2 = Sheets(i).Name 'إضافة اسم الورقة في المدى
     End With 'إنهاء التحديد
        Sheets(i).Range("B6:n" & lr).AdvancedFilter Action:=xlFilterCopy _
        , CriteriaRange:=Sheets(2).Range("f4:f5"), CopyToRange:=Sheets(2).Range("B" & lr1), _
        Unique:=False 'عمل تصفية متقدمة لجميع أوراق الحلقة التكرارية ووضها في ورقة الدرجات بالتتابع كل ورقة تصفيتها تحت الأخرى
       Sheets(i).Range("n6:n" & lr).ClearContents 'مسح البيانات في المدى الذي أضيفت في ه اسم الورقة
        Next i 'من أجل تكرار الحلقة المتمثلة في المتغير (i)وإنهائها
          For Each CL In Sheets(2).Range("n8:n1000") 'عمل حلقة تكرارية أخرى من أجل حذف صفوف العناوين التي تم الحصول عليها من التصفية المتقدمة السابقة
          If CL.Value = "الصف" Then ' تحديد شرط إذا كان الصف يحتويى على كلمة (الصف ) قم بالآتي
          CL.EntireRow.Delete 'احذف الصف
          End If ' إنهاء الشرط
          Next CL 'تكرار الحلقة وإنهائها
        
          With Sheets(2).Range("A8:A1000") 'تحديد المدى من أجل عمل ترقيم تلقائي للبيانات التي تم الحصول عليها في ورقة الدرجات
         .FormulaR1C1 = "=IF(RC2="""","""",MAX(R7C1:R[-1]C)+1)" 'معادلة الترقيم التلقائي
         .Value = .Value ' تحويل الصيغ في المجى إلى قيم
          End With ' إنهاء التحديد
          With Sheets(2).Range("a8:n1000") 'تحديد المدى من أجل فرز البيانات حسب التسلسل الرقمي لها للتخلص من الفراغات
         .Sort Key1:=Sheets(2).Range("A8"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal ' تحديد عملية الفرز حسب عمود التسلسل
        End With ' إنهاء التحديد
       
           Application.Calculation = xlAutomatic 'إرجاع الحساب تلقائي
           Application.EnableEvents = True ' السماح بالأحداث الأخرى
           Application.ScreenUpdating = True 'إرجاع اهتزاز الشاشة
          
End Sub 'إنهاء الكود

تم عمل قائمة بحالة الطالب لزيادة المطلوب

أم بالدوال أجد أن الأمر متعب شوي ويحتاج إلى وقت بالنسبة لي 

ريما أحد الأخوة لديه فكرة أفضل في هذا الأمر

م.rar

[سيد الأكرت]

عن نفسي اكرر شكرى الممدود لشخصكم الكريم للتفاعل المستمر مع الأعضاء