fantap

شكرا جزيلا و لكن يوجد مشكلة قد ظهرت حاولت التصحيح بهذا الكود 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 ظهرت القوائم المنسدلة في بعض الجمعة و السبت و بعض العطلات الرسمية

السلام عليكم تم التعديل علي الكود و تم الاصلاح و لكن يوجد بطئ شديد جدا في تكوين الشيت الجديد 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

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

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

شكرا جزيلا مجهود مميز و لكني لا اريد استخدام معادلات ولا استخدام اكواد VBA خالص الاحترام و التقدير لشخصكم الكريم

السلام عليكم مرفق شيت اكسيل اريد عمل تصفيه متقدمه بحيث اريد تصفيه القيم التي تبدا بـ 110 و التي تبدا بـ 111 و التي تبدا بـ 112 و التي تبدا بـ 113 و استباعدهم و الابقاء علي باقي القيم حيث تم اضافة جدول مساعد و تم تسميه باسم نفس العمود الذي عليه معيار التصفيه كالتالي في العمود Q <>110* <>111* <>112* <>113* و لكن لا تعمل التصفيه لا ادري لماذا برجاء المساعدة مع العلم انني اعمل التصفيه في نفس الشيت علما انه تم تحويل كل القيم الي الصورة النصيه.... شكرا جزيلا انا اريد استخدام التصفيه المتقدمه و لا اريد استخدام المعادلات او استخدام اكواد VBA ايداعات.xlsx

شكرا جزيلا بارك الله في حضرتك.... خالص الاحنترام و التقدير

السلام عليكم مرفق ملف اكسيل يحتوي علي 2 شيت اكسيل الشيت الرئيسي هو شيت العملاء مكون من عدد 7 اعمدة العمود الاول هو اسم العميل العمود الثاني هو رقم حساب العميل العمود الثالث هو الايداع النقدي العمود الرابع هو السحب النقدي العمود الخامس هو تحويلات الخارجيه العمود السادس هو للتحويلات الداخليه العمود السابع هو للفتح الجديد و الشيت الثاني يسمي شيت الشرايح اريد عندما اعمل عند عمل نسخ و لصق اسماء العملاء و بيانتهم يتم رحيل البيانات حسب شرائيهم في الجدول الثاني بشكل التوماتيكي بحيث لو ان العميل يقوم باي عمليه مثلا مثلا يتم ترحيل العميل حسب الشريحه الخاصه به و نوع العمليه سواء كانت ايداع او سحب او تحويل داخلي او خارجي او فتح جديد و عمل اجمالي حسب المبالغ الخاصه به شرائح.xlsx

شكرا جزيلا... علي الرد أستاذنا الغالي إبراهيم الحداد جزاك الله خير الجزاء و زادك الله من العلم الوفير... أنا لا أريد كتابة أي اكواد كل ما في الموضوع محتاج طريقه بسيطه لعمل ذلك إن امكن باستخدام التصفية المتقدمه و أي طريقه بسيطه أخري إن امكن ذلك شكرا جزيلا

السلام عليكم و رحمة الله و بركاته مرفق شيت اكسيل مكون من عمود واحد فقط باسم رقم الحساب يكون به حجم بيانات ضخم جدا ..... انا اريد ان اعمل فرز و تصفيه للارقام الحسابات التي تبدا بـ فقط 080 و ايضا 081 و ايضا 082 برجاء المساعدة لان الطريقه التقلديه للفرز لا تفي بهذا الغرض و كيفية عمل ذلك شكرا جزيلا ارقام حسابات.xlsx

السلام عليكم برجاء المساعدة في عمل Grouping باستخدام pivot table لقيم مختلفة المدي علي سبيل المثال للتوضيح عمل جروب للشريحه الاولي من 1 الي 1000 و الشريحه الثانيه من 1000 الي 10000 و الشريحه الثالثه من 10000 الي 40000 و هكذا باستخدام pivot table و مرفق مثال عملي و لكن range منتظم من البيانات شكرا جزيلا تقبلوا تحياتي مثال عملي .xlsx

للرفع

السلام عليكم انا عندي عمود يسمي رقم الحساب ( عبارة عن نص) داخل pivot table و اريد ان اعمل تصفيه من خلال التسميه و اريد ان اظهر ارقام الحسابات التي تبدا بـ 080 و ايضا ارقام الحسابات التي تبدا بـ 081 في نفس الوقت لا استطيع فعل ذلك برجاء مساعدتي في هذا الشان مرفق مثال و تم ارفاق صور مثال.xlsx

شكرا جزيلا لقد قمت بعمل الطريقه الاولي text to columns و كانت النتيجه ممتازة

السلام عليكم عندي مشكله مع شريط الاكسيل الخاص بي حيث الشيت من ضمن محتوايه عمودين (اسم العمود الاول تاريخ الاصدار ومعه توقيت الاصدار و العمود الثاني عمود الصرف و معه توقيت الصرف) و العمودين متجاورين مع بعضهم يمكن ان يكون ان يكو ن تاريخ الاصدار هو نفسه تاريخ الصرف و ممكن ان يكون تاريخ الصرف بعد تاريخ الاصدار المشكله عندما اقوم بعمل تعبئة سريعه لفصل تاريخ الصرف عن توقيت الصرف يقوم بعمل تعبئه سريعه علي اساس تاريخ الاصدار و ليس تاريخ الصرف فبتالي سوف يكون اختلاف في العمود الجديد ملحوظة اقوم بعمل اخفاء لتاريخ و وقت الاصدار حتي لا تحدث هذه المشكله.هل يوجد حل بديل بدلا من عمل اخفاء لاي عمود داخل الشيت الخاص بي ..شكرا جزيلا مثال.xlsx