كود لجدول الحصص الاضافيه

[shanghity11]

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

الأخوة الكرام في المنتدى 

آمل المساعدة في الملف المرفق 

لدى ملف للحصص الإضافية وبما أن الشهر يبدأ من يوم 21 من كل شهر وحتى يوم 20 الشهر الذي يليه 

أريد أن أحصر عدد الحصص الإضافية لك معلم وبدلا من إضافة الأيام والتواريخ بشكل يدوي آمل إضافة كود تلقائي يملأ الأيام والتواريخ بناء على بداية الفترة ونهاية الفترة مع حذف أيام الإجازة الأسبوعية (الجمعة والسبت)

 

وشاكرا لكم سلفا ما تقدمونه من مساعدة .

جدول الحصص الإضافية.xlsx

[محمد هشام.]

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

جرب هذا 

Sub Remplissez_jours_dates()
    Dim début As Date, DateFin As Date, CrDate As Date
    Dim tmp As Long, DayArr As Variant
    Dim WS As Worksheet: Set WS = Sheets("البنين")

    If WS.Range("K2").Value = "" Or WS.Range("O2").Value = "" Or _
    Not IsDate(WS.Range("K2").Value) Or Not IsDate(WS.Range("O2").Value) Then
        MsgBox "يرجى التأكد من صحة التواريخ ", vbExclamation
        Exit Sub
    End If

    début = WS.Range("K2").Value
    DateFin = WS.Range("O2").Value

    If début > DateFin Then: MsgBox "لا يمكن أن يكون تاريخ البدءأكبر من تاريخ الانتهاء", vbExclamation: Exit Sub

    Application.ScreenUpdating = False

    WS.Range("E4:AH5").ClearContents

    DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس")

    tmp = 4
    CrDate = début

    Do While CrDate <= DateFin
        If Weekday(CrDate, vbSunday) <> 6 And Weekday(CrDate, vbSunday) <> 7 Then
            If tmp > 34 Then Exit Do

            WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1)
            WS.Cells(5, tmp).Value = CrDate

            tmp = tmp + 1
        End If
        CrDate = CrDate + 1
    Loop
    Application.ScreenUpdating = True
End Sub

وفي حدث ورقة البنين 

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("K2,O2")) Is Nothing Then
        Remplissez_jours_dates
    End If
End Sub

 

جدول الحصص الإضافية.xlsb

تم تعديل ديسمبر 1 بواسطه محمد هشام.

[shanghity11]

كفيت ووفيت أخ محمد هشام 

بارك الله فيك وفي علمك

 

[shanghity11]

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

 

أخ محمد هشام إذا أمكن تضيف أيام الإجازة الأسبوعية لكن يكون عليه تظليل بلون معين .

تم تعديل ديسمبر 2 بواسطه shanghity11

[محمد هشام.]

    début = WS.Range("K2").Value
    DateFin = WS.Range("O2").Value
    Set Rng = WS.Range("D4:AH5")
    
    If début > DateFin Then : MsgBox "لا يمكن أن يكون تاريخ البدء أكبر من تاريخ الانتهاء", vbExclamation :Exit Sub
 
    Application.ScreenUpdating = False
    
    With Rng
    .ClearContents
    .Interior.ColorIndex = xlNone
    End With

    DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت")
    tmp = 4
    CrDate = début
    Do While CrDate <= DateFin
        If tmp > 34 Then Exit Do

        WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1)
        WS.Cells(5, tmp).Value = CrDate

       If Weekday(CrDate, vbSunday) >= 6 Then
            WS.Cells(4, tmp).Interior.Color = RGB(255, 255, 0)
            WS.Cells(5, tmp).Interior.Color = RGB(255, 255, 0)
         End If
        tmp = tmp + 1
        CrDate = CrDate + 1
    Loop
    Application.ScreenUpdating = True

 

 

جدول الحصص الإضافية.xlsb

تم تعديل ديسمبر 2 بواسطه محمد هشام.

[shanghity11]

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

أخ محمد هشام

نسخت الكود وعمله ممتاز . لكن هناك إشكالية أن اليوم الأول من الفترة مكرر

جدول الحصص الإضافية.xlsb

[محمد هشام.]

Sub Remplissez_jours_dates()
    Dim début As Date, DateFin As Date, CrDate As Date
    Dim tmp As Long, DayArr As Variant, i As Long
    Dim WS As Worksheet: Set WS = Sheets("البنين")
    
    If WS.Range("K2").Value = "" Or WS.Range("O2").Value = "" Or _
       Not IsDate(WS.Range("K2").Value) Or Not IsDate(WS.Range("O2").Value) Or _
       WS.Range("K2").Value > WS.Range("O2").Value Then
        MsgBox "يرجى التأكد من صحة التواريخ " & vbCrLf & _
               "وتاريخ البدء لا يكون أكبر من تاريخ الانتهاء", vbExclamation
        Exit Sub
    End If
    
    début = WS.Range("K2").Value
    DateFin = WS.Range("O2").Value
  ' لاخر اسم في عمود b
   Dim LastRow As Long
   LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
   'لاخر الكشف الصف 45
'   LastRow = 45
    Application.ScreenUpdating = False
    
    WS.Range("D4:AH5").ClearContents
    With WS.Range("D4:AH45")
        .Interior.Pattern = xlNone
        .Font.Color = RGB(0, 0, 0)
    End With

    DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت")
    tmp = 4
    CrDate = début

    Do While CrDate <= DateFin
        If tmp > 34 Then Exit Do

        WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1)
        WS.Cells(5, tmp).Value = CrDate

        If Weekday(CrDate, vbSunday) >= 6 Then
            WS.Range(WS.Cells(4, tmp), WS.Cells(LastRow, tmp)).Interior.Color = RGB(255, 255, 0)
            WS.Range(WS.Cells(4, tmp), WS.Cells(5, tmp)).Font.Color = RGB(255, 0, 0)
        End If

        tmp = tmp + 1
        CrDate = CrDate + 1
    Loop

    Application.ScreenUpdating = True
End Sub

 

 

جدول الحصص الإضافية 2.xlsb

تم تعديل ديسمبر 3 بواسطه محمد هشام.

[shanghity11]

بارك الله في جهودك أخ محمد 

وبارك الله في جهود أعضاء المنتدى جميعا

[shanghity11]

باقي شي آخر أخ محمد

أريد أن يمتد تظليل أيام الإجازة الأسبوعية إلى نهاية الكشف

 

واعذرونا على الطلبات الكثيرة بارك الله فيكم

[محمد هشام.]

15 ساعات مضت, shanghity11 said:

أريد أن يمتد تظليل أيام الإجازة الأسبوعية إلى نهاية الكشف

تم تعديل المشاركة السابقة لتتناسب مع طلبك 

تم تعديل ديسمبر 3 بواسطه محمد هشام.

[shanghity11]

بارك الله فيك أخ محمد وفي علمك

عندي ملاحظة بسيطة وهي أن التظليل ينتهي حيث تنتهي الأسماء

وأنا أريد أن يكون التظليل إلى نهاية الكشف حتى لو لم تكن هناك أسماء 

بمجرد إدخال نهاية الفترة يتم التظليل إلى نهاية الكشف تلقائيا

 

حفظك الله وبارك فيك ولا عدمناك

[محمد هشام.]

58 دقائق مضت, shanghity11 said:

وأنا أريد أن يكون التظليل إلى نهاية الكشف حتى لو لم تكن هناك أسماء

لقد تم فعلا وضع الإختيار في الكود المقترح سابقا ربما لم تنتبه لهدا

في 2‏/12‏/2024 at 13:12, محمد هشام. said:

' لاخر اسم في عمود b
   Dim LastRow As Long
   LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
   'لاخر الكشف الصف 45
'   LastRow = 45

في حالتك يكفي البقاء على 

Dim LastRow As Long
LastRow = 45

 

[shanghity11]

بارك الله فيك أخ محمد

التظليل يتم إلى آخر اسم . 

ويبقى باقي الكشف إلى صف 45 بدون تظليل

وأنا أريد التظليل إلى صف 45 حتى لو لم يكن هناك أسماء

 

شاكرا لك رحابة صدرك بارك الله فيك

[محمد هشام.]

اخي هدا ما يفعله الكود فعلا بعد تعديلك للسطر المشار إليه  

LastRow = 45

اي عدد الصفوف لديك على الملف 

او تثبيتها هنا مباشرة 

 WS.Range(WS.Cells(4, tmp), WS.Cells(45, tmp)).Interior.Color = RGB(255, 255, 0)

 

 

جدول الحصص الإضافية 3.xlsb

[shanghity11]

بارك الله فيك أخ محمد

تمت العملية بنجاح

 

[سمير أيوب]

الله یبارك فیكم