برجاء المساعدة في التعديل علي هذا الكود و غلق خلايا الجمعة و السبت و العطلات الرسمية

[fantap]

السلام عليكم 

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

حيث  عندا نضغط علي شهر  جديد  بيتم انشاء شهر جديد  في شيت جديد له نفس الترتيب  ايام الجمعة  السبت بتختلف من شهر الي اخر  

ايام الجمعة و السبت لها لون مميز 
برجاء المساعدة

Untitled - Copy - Copy.xlsm

تم تعديل الثلاثاء at 18:19 بواسطه fantap

[fantap]

السلام عليكم  تم التعديل  علي الكود  و تم الاصلاح  و لكن  يوجد  بطئ شديد جدا في تكوين الشيت الجديد 

Sub CreateNextMonthSheetAndLockOfficialHolidays()

    Dim ws As Worksheet, copiedSheet As Worksheet, monthTable As Worksheet, dataSheet As Worksheet
    Dim currentMonth As String, nextMonth As String, nextMonthArabic As String
    Dim i As Integer, foundRow As Range
    Dim dateCell As Range, checkDate As Date
    Dim holidayRange As Range, holidayCell As Range
    Dim col As Range
    Dim isHoliday As Boolean
    Dim colNum As Long
    Dim weekdayNum As Integer
    Dim lockedText As String

    ' إعداد الشيتات
    Set ws = ActiveSheet
    Set monthTable = ThisWorkbook.Sheets("MonthNames")
    Set dataSheet = ThisWorkbook.Sheets("data")
    currentMonth = ws.Name

    ' جلب النص من MonthNames!H1
    lockedText = monthTable.Range("H1").Value

    ' البحث عن اسم الشهر الحالي
    Set foundRow = monthTable.Range("A1:A12").Find(What:=currentMonth, LookIn:=xlValues, LookAt:=xlWhole)
    If foundRow Is Nothing Then
        MsgBox "Current sheet name '" & currentMonth & "' not found in MonthNames sheet.", vbCritical
        Exit Sub
    End If

    ' تحديد الشهر التالي
    If foundRow.Row = 12 Then
        nextMonth = monthTable.Range("A1").Value
        nextMonthArabic = monthTable.Range("B1").Value
    Else
        nextMonth = monthTable.Cells(foundRow.Row + 1, 1).Value
        nextMonthArabic = monthTable.Cells(foundRow.Row + 1, 2).Value
    End If

    ' التأكد أن الشيت غير موجود مسبقًا
    For i = 1 To ThisWorkbook.Sheets.Count
        If ThisWorkbook.Sheets(i).Name = nextMonth Then
            MsgBox "Sheet '" & nextMonth & "' already exists.", vbExclamation
            Exit Sub
        End If
    Next i

    ' نسخ الشيت الحالي
    ws.Copy After:=ws
    Set copiedSheet = ActiveSheet

    On Error Resume Next
    copiedSheet.Name = nextMonth
    If Err.Number <> 0 Then
        MsgBox "Error renaming the new sheet.", vbCritical
        Exit Sub
    End If
    On Error GoTo 0

    ' تفريغ البيانات
    copiedSheet.Range("F11:AJ500").ClearContents

    ' تحديث D5
    copiedSheet.Range("D5").Value = nextMonthArabic

    ' فك الحماية
    copiedSheet.Unprotect Password:="1234"
    copiedSheet.Range("F11:AJ130").Locked = False

    ' قراءة العطلات من الشيت "data"
    Set holidayRange = dataSheet.Range("F5:F25")

    ' المرور على الأعمدة من F إلى AJ (أرقام الأعمدة 6 إلى 36)
    For colNum = 6 To 36
        Set dateCell = copiedSheet.Cells(10, colNum)
        Set col = copiedSheet.Range(copiedSheet.Cells(11, colNum), copiedSheet.Cells(130, colNum))
        isHoliday = False

        If IsDate(dateCell.Value) Then
            checkDate = CDate(dateCell.Value)
            ' ترتيب الأسبوع يبدأ من السبت: السبت = 1، الجمعة = 7
            weekdayNum = Weekday(checkDate, vbSaturday)

            ' التحقق من العطلات الرسمية (تجاهل الوقت)
            For Each holidayCell In holidayRange
                If IsDate(holidayCell.Value) Then
                    If Int(CDate(holidayCell.Value)) = Int(checkDate) Then
                        isHoliday = True
                        Exit For
                    End If
                End If
            Next holidayCell

            ' إذا الجمعة أو السبت أو عطلة
            If isHoliday Or weekdayNum = 1 Or weekdayNum = 7 Then
                Dim r As Range
                For Each r In col
                    If Trim(r.Value) = "" Then
                        r.Value = lockedText
                    End If
                Next r

                col.Locked = True
                On Error Resume Next
                col.Validation.Delete
                On Error GoTo 0
            End If
        End If
    Next colNum

    ' إعادة الحماية
    copiedSheet.Protect Password:="1234", UserInterfaceOnly:=True

    ' تفعيل الشيت الجديد
    copiedSheet.Activate

    MsgBox "✅ Sheet '" & nextMonth & "' has been created successfully." & vbCrLf & _
           "✔ Fridays, Saturdays, and official holidays are now locked.", vbInformation

End Sub

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

Sub CreateNextMonthSheetAndLockOfficialHolidays()

    ' تسريع الكود
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False

    Dim ws As Worksheet, copiedSheet As Worksheet, monthTable As Worksheet, dataSheet As Worksheet
    Dim currentMonth As String, nextMonth As String, nextMonthArabic As String
    Dim i As Integer, foundRow As Range
    Dim dateCell As Range, checkDate As Date
    Dim holidayRange As Range, holidayCell As Range
    Dim col As Range
    Dim isHoliday As Boolean
    Dim colNum As Long
    Dim weekdayNum As Integer
    Dim lockedText As String

    ' إعداد الشيتات
    Set ws = ActiveSheet
    Set monthTable = ThisWorkbook.Sheets("MonthNames")
    Set dataSheet = ThisWorkbook.Sheets("data")
    currentMonth = ws.Name

    ' جلب النص من MonthNames!H1
    lockedText = monthTable.Range("H1").Value

    ' البحث عن اسم الشهر الحالي
    Set foundRow = monthTable.Range("A1:A12").Find(What:=currentMonth, LookIn:=xlValues, LookAt:=xlWhole)
    If foundRow Is Nothing Then
        MsgBox "Current sheet name '" & currentMonth & "' not found in MonthNames sheet.", vbCritical
        GoTo Cleanup
    End If

    ' تحديد الشهر التالي
    If foundRow.Row = 12 Then
        nextMonth = monthTable.Range("A1").Value
        nextMonthArabic = monthTable.Range("B1").Value
    Else
        nextMonth = monthTable.Cells(foundRow.Row + 1, 1).Value
        nextMonthArabic = monthTable.Cells(foundRow.Row + 1, 2).Value
    End If

    ' التأكد أن الشيت غير موجود مسبقًا
    For i = 1 To ThisWorkbook.Sheets.Count
        If ThisWorkbook.Sheets(i).Name = nextMonth Then
            MsgBox "Sheet '" & nextMonth & "' already exists.", vbExclamation
            GoTo Cleanup
        End If
    Next i

    ' نسخ الشيت الحالي
    ws.Copy After:=ws
    Set copiedSheet = ActiveSheet

    On Error Resume Next
    copiedSheet.Name = nextMonth
    If Err.Number <> 0 Then
        MsgBox "Error renaming the new sheet.", vbCritical
        GoTo Cleanup
    End If
    On Error GoTo 0

    ' تفريغ البيانات
    copiedSheet.Range("F11:AJ500").ClearContents

    ' تحديث D5
    copiedSheet.Range("D5").Value = nextMonthArabic

    ' فك الحماية
    copiedSheet.Unprotect Password:="1234"
    copiedSheet.Range("F11:AJ130").Locked = False

    ' قراءة العطلات من الشيت "data"
    Set holidayRange = dataSheet.Range("F5:F25")

    ' المرور على الأعمدة من F إلى AJ (أرقام الأعمدة 6 إلى 36)
    For colNum = 6 To 36
        Set dateCell = copiedSheet.Cells(10, colNum)
        Set col = copiedSheet.Range(copiedSheet.Cells(11, colNum), copiedSheet.Cells(130, colNum))
        isHoliday = False

        If IsDate(dateCell.Value) Then
            checkDate = CDate(dateCell.Value)
            
            ' استخدام Weekday مع vbSaturday: السبت = 1، الجمعة = 7
            weekdayNum = Weekday(checkDate, vbSaturday)

            ' التحقق من العطلات الرسمية
            For Each holidayCell In holidayRange
                If IsDate(holidayCell.Value) Then
                    If Int(CDate(holidayCell.Value)) = Int(checkDate) Then
                        isHoliday = True
                        Exit For
                    End If
                End If
            Next holidayCell

            ' إذا الجمعة (7) أو السبت (1) أو عطلة
            If weekdayNum = 1 Or weekdayNum = 7 Or isHoliday Then
                ' كتابة "خلية مغلقة" من MonthNames!H1 في الخلايا الفارغة
                Dim r As Range
                For Each r In col
                    If Trim(r.Value) = "" Then
                        r.Value = lockedText
                    End If
                Next r

                ' قفل العمود وحذف القائمة المنسدلة
                col.Locked = True
                On Error Resume Next
                col.Validation.Delete
                On Error GoTo 0
            End If
        End If
    Next colNum

    ' إعادة الحماية
    copiedSheet.Protect Password:="1234", UserInterfaceOnly:=True

    ' تفعيل الشيت الجديد
    copiedSheet.Activate

    MsgBox "✅ Sheet '" & nextMonth & "' has been created successfully." & vbCrLf & _
           "✔ Fridays, Saturdays, and official holidays are now locked.", vbInformation

Cleanup:
    ' إعادة الإعدادات لطبيعتها
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True

End Sub