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

fantap · April 1

السلام عليكم

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

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

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

Untitled - Copy - Copy.xlsm

تم تعديل April 1 بواسطه fantap

fantap · April 1

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

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

mahmoud nasr alhasany · April 3

تفضل جرب هذا الحدث

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 Cell
    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
                ' كتابة النص في الخلايا الفارغة وقفل العمود وحذف القائمة المنسدلة
                Dim r As Range
                For Each r In col
                    If Trim(r.Value) = "" Then
                        r.Value = lockedText
                    End If
                    r.Locked = True
                Next r
                On Error Resume Next
                col.Validation.Delete
                On Error GoTo 0
            Else
                ' السماح بالكتابة في الأيام الأخرى
                col.Locked = False
            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, and the text '" & lockedText & "' has been added." & vbCrLf & _
           "✔ Dropdown lists have been removed from locked days.", vbInformation

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

End Sub

fantap · April 4

شكرا جزيلا و لكن يوجد مشكلة قد ظهرت

حاولت التصحيح بهذا الكود

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, r As Range
    Dim isHoliday As Boolean
    Dim colNum As Long, rowNum As Long
    Dim weekdayNum As Integer
    Dim lockedText As String
    Dim wd As Integer
    Dim holidayDate As Date

    Set ws = ActiveSheet
    Set monthTable = ThisWorkbook.Sheets("MonthNames")
    Set dataSheet = ThisWorkbook.Sheets("data")
    currentMonth = ws.Name
    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.", 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
    On Error GoTo 0

    copiedSheet.Range("F11:AJ500").ClearContents
    copiedSheet.Range("D5").Value = nextMonthArabic
    copiedSheet.Unprotect Password:="1234"
    copiedSheet.Range("F11:AJ130").Locked = False

    Set holidayRange = dataSheet.Range("F5:F25")

    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)
            weekdayNum = Weekday(checkDate, vbSaturday)

            For Each holidayCell In holidayRange
                If IsDate(holidayCell.Value) Then
                    If Int(holidayCell.Value) = Int(checkDate) Then
                        isHoliday = True
                        Exit For
                    End If
                End If
            Next holidayCell

            If weekdayNum = 1 Or weekdayNum = 7 Or isHoliday Then
                For Each r In col
                    If Trim(r.Value) = "" Then r.Value = lockedText
                    r.Locked = True
                Next r
                On Error Resume Next: col.Validation.Delete: On Error GoTo 0
            Else
                col.Locked = False
            End If
        End If
    Next colNum

    ' ✅ تصحيح الأعمدة غير العطلات التي تم قفلها خطأ
    For colNum = 6 To 36
        If IsDate(copiedSheet.Cells(10, colNum).Value) Then
            checkDate = copiedSheet.Cells(10, colNum).Value
            wd = Weekday(checkDate, vbSaturday)
            isHoliday = False
            If wd = 1 Or wd = 7 Then
                isHoliday = True
            Else
                For Each holidayCell In holidayRange
                    If IsDate(holidayCell.Value) Then
                        holidayDate = holidayCell.Value
                        If Int(checkDate) = Int(holidayDate) Then
                            isHoliday = True: Exit For
                        End If
                    End If
                Next holidayCell
            End If

            If Not isHoliday Then
                Dim sourceCell As Range, targetCell As Range
                Dim hasValidation As Boolean
                Dim copiedValidation As Validation

                Set sourceCell = copiedSheet.Cells(11, colNum)
                hasValidation = False
                On Error Resume Next
                hasValidation = (sourceCell.Validation.Type <> -1)
                On Error GoTo 0

                If hasValidation Then
                    Set copiedValidation = sourceCell.Validation
                    For rowNum = 11 To 230
                        Set targetCell = copiedSheet.Cells(rowNum, colNum)
                        If targetCell.Interior.Color = RGB(255, 200, 200) Then
                            If Trim(targetCell.Value) = "" Or Trim(targetCell.Value) = lockedText Then
                                With targetCell
                                    .ClearContents
                                    .Interior.ColorIndex = xlColorIndexNone
                                    .Locked = False
                                    .Validation.Delete
                                    copiedValidation.Modify targetCell
                                End With
                            End If
                        End If
                    Next rowNum
                End If
            End If
        End If
    Next colNum

    copiedSheet.Protect Password:="1234", UserInterfaceOnly:=True
    copiedSheet.Activate

    MsgBox "✅ Sheet '" & nextMonth & "' created successfully." & vbCrLf & _
           "✔ Fridays, Saturdays, and holidays locked." & vbCrLf & _
           "✔ Mistaken columns fixed and dropdowns restored.", vbInformation

Cleanup:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True

End Sub

ظهرت القوائم المنسدلة في بعض الجمعة و السبت و بعض العطلات الرسمية

تم تعديل April 4 بواسطه fantap
تصحيح الكود

تسجيل الدخول

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

الردود الموصى بها

fantap

fantap

mahmoud nasr alhasany

fantap

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information