mahmoud nasr alhasany

هذا الكود الصحيح بخصوص تنسيق الاعمدة المختلفة من العمود C حتى العمود I هل يمكن اضافة ودمج كود خاص بتنسيق العمود المحدد فى العمود O Sub FormatUniqueCellsInRow() Dim ws As Worksheet Dim lastRow As Long Dim r As Long Dim values(1 To 7) As Variant ' لتخزين القيم من C إلى I (7 أعمدة) Dim i As Integer, j As Integer Dim count As Integer ' 1. إعدادات ورقة العمل Set ws = ThisWorkbook.Sheets("Sheet1") ' ?? غيّر "Sheet1" إلى اسم ورقتك الفعلي ' 2. تحديد آخر صف يحتوي على بيانات في العمود C lastRow = ws.Cells(ws.Rows.count, "C").End(xlUp).Row ' 3. تنظيف أي تنسيقات سابقة من الأعمدة C إلى I ' هذا مهم لضمان تطبيق التنسيقات الجديدة فقط ws.Range("C3:I" & lastRow).Interior.ColorIndex = xlNone ' مسح لون التعبئة ws.Range("C3:I" & lastRow).Font.ColorIndex = xlAutomatic ' مسح لون الخط المخصص ws.Range("C3:I" & lastRow).Font.Bold = False ' إلغاء الخط العريض ' 4. المرور على كل صف بدءًا من الصف 3 (أو أي صف تبدأ منه بياناتك) For r = 3 To lastRow ' ابدأ من الصف الذي تبدأ منه بياناتك ' قراءة القيم من العمود C إلى I للصف الحالي وتخزينها في مصفوفة ' Column C is index 1 (i + 2 where i=1 means 1+2=3 which is C) For i = 1 To 7 values(i) = ws.Cells(r, i + 2).Value ' i+2 لأن C هو العمود الثالث Next i ' فحص كل قيمة في الصف لتحديد إذا كانت فريدة داخل هذا الصف For i = 1 To 7 ' تكرار على كل عمود من C إلى I (بواسطة فهرس المصفوفة i) count = 0 ' إعادة تعيين العداد لكل قيمة ' مقارنة القيمة الحالية (values(i)) بجميع القيم الأخرى في نفس الصف For j = 1 To 7 If values(j) = values(i) Then count = count + 1 End If Next j ' إذا كانت القيمة فريدة (تكررت مرة واحدة فقط في الصف) If count = 1 Then ' تطبيق التنسيق على الخلية المحددة التي تحتوي على القيمة الفريدة With ws.Cells(r, i + 2) ' i + 2 يمثل رقم العمود الفعلي (C, D, E...) .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء (RGB for exact yellow) .Font.Color = RGB(255, 0, 0) ' خط أحمر (RGB for exact red) .Font.Bold = True ' خط عريض End With End If Next i Next r ' إذا كنت لا تزال ترغب في الاحتفاظ بالعمود O بالنص الوصفي، يمكنك ترك الكود الخاص بك ' Sub CheckDifferences() وتشغيله بعد هذا الكود، أو دمج المنطق هنا. ' لكن هذا الكود يركز فقط على تنسيق الخلايا من C إلى I. End Sub

السلام عليكم ورحمة الله وبركاتة الرجاء مساعدتى فى هذه المشكلة يوجد اعمدة بأسماء الاصناف لكل بلد وتم عمل المطلوب من خلال معادلة اكسيل ومعادلة VBA من خلال المعادلة المرتبطة بالكود VBA =GetUniqueColumns(C3:I3) اريد تنسيق العمود O3 الاعمدة المختلفة كل الخلية باللون الاصفر و الحروف باللون الاحمر كما هو مدرج فى الصورة Sub FormatUniqueColumnsDirectly() Dim ws As Worksheet Dim DataRange As Range Dim uniqueColsCollection As New Collection ' This will store the unique column letters Dim cell As Range Dim count As Long Dim colLetter As String Dim targetColumn As Excel.Range Dim i As Long ' --- إعداداتك --- ' 1. تأكد من أن اسم الورقة صحيح Set ws = ThisWorkbook.Sheets("Sheet1") ' غيّر "Sheet1" إلى اسم ورقتك الفعلي ' 2. تأكد من أن نطاق البيانات صحيح ' هذا النطاق هو الذي سيتم البحث فيه عن القيم الفريدة. ' على سبيل المثال، إذا كانت بياناتك في الأعمدة من A إلى Z، ومن الصف 1 إلى الصف 100 Set DataRange = ws.Range("A1:Z100") ' اضبط هذا على نطاق بياناتك الفعلي Debug.Print "Worksheet Name: " & ws.Name Debug.Print "Data Range to check for uniqueness: " & DataRange.Address ' --- الخطوة 1: تحديد الأعمدة الفريدة بناءً على القيم الفريدة داخل النطاق --- ' (هذا هو جوهر ما كانت تفعله دالة GetUniqueColumns) For Each cell In DataRange ' تأكد من أن الخلية ليست فارغة، وإلا فقد يتم عد الخلايا الفارغة كقيم فريدة If Not IsEmpty(cell.Value) Then ' حساب عدد تكرارات القيمة في النطاق الكلي count = Application.WorksheetFunction.CountIf(DataRange, cell.Value) If count = 1 Then ' إذا كانت القيمة فريدة (تظهر مرة واحدة فقط) ' الحصول على حرف العمود من عنوان الخلية (مثال: من $C$5 نحصل على C) colLetter = Split(cell.Address(True, False), "$")(0) Debug.Print "Found unique value: " & cell.Value & " in column: " & colLetter On Error Resume Next ' لتجنب الأخطاء إذا تم إضافة نفس حرف العمود بالفعل uniqueColsCollection.Add colLetter, CStr(colLetter) ' إضافة حرف العمود إلى المجموعة On Error GoTo 0 End If End If Next cell Debug.Print "Number of unique columns identified: " & uniqueColsCollection.count ' --- الخطوة 2: تطبيق التنسيق على الأعمدة الفريدة التي تم تحديدها --- If uniqueColsCollection.count > 0 Then For Each columnLetter In uniqueColsCollection Debug.Print "Attempting to format column: " & columnLetter ' الحصول على كائن العمود بالكامل باستخدام حرف العمود On Error Resume Next ' في حالة كان حرف العمود غير صالح أو فارغ Set targetColumn = ws.Columns(columnLetter) On Error GoTo 0 If Not targetColumn Is Nothing Then Debug.Print "Applying formatting to column: " & columnLetter ' تطبيق التنسيق على العمود المحدد With targetColumn.Interior .Color = RGB(255, 255, 0) ' تعبئة صفراء End With With targetColumn.Font .Color = RGB(255, 0, 0) ' خط أحمر .Bold = True ' خط عريض .Size = 12 ' حجم الخط End With ' إضافة حدود للعمود With targetColumn .Borders(xlEdgeLeft).LineStyle = xlContinuous .Borders(xlEdgeRight).LineStyle = xlContinuous .Borders(xlEdgeTop).LineStyle = xlContinuous .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders.Weight = xlThin ' حدود رفيعة End With targetColumn.ColumnWidth = 15 ' ضبط عرض العمود targetColumn.HorizontalAlignment = xlCenter ' محاذاة النص في المنتصف Else Debug.Print "Error: Could not set targetColumn for letter: " & columnLetter & ". It might be an invalid column letter." End If Set targetColumn = Nothing ' إعادة تعيين المتغير للتكرار التالي Next columnLetter Else MsgBox "لا توجد أعمدة فريدة لتنسيقها في النطاق المحدد.", vbInformation End If ' --- تنظيف المتغيرات --- Set ws = Nothing Set DataRange = Nothing Set uniqueColsCollection = Nothing End Sub ' Keep your GetUniqueColumns function if you still need it for displaying the message Function GetUniqueColumns(DataRange As Range) As String Dim cell As Range Dim uniqueCols As New Collection Dim tempArr() As String Dim result As String Dim i As Long Dim colLetter As String Dim count As Long For Each cell In DataRange count = Application.WorksheetFunction.CountIf(DataRange, cell.Value) If count = 1 Then colLetter = Split(cell.Address(True, False), "$")(0) On Error Resume Next uniqueCols.Add colLetter, CStr(colLetter) On Error GoTo 0 End If Next cell If uniqueCols.count = 0 Then ReDim tempArr(0 To 0) Else ReDim tempArr(1 To uniqueCols.count) For i = 1 To uniqueCols.count tempArr(i) = "العمود " & uniqueCols.Item(i) & " مختلف" Next i End If If UBound(tempArr) = 0 Or uniqueCols.count = 0 Then result = "" ElseIf UBound(tempArr) = 1 Then result = tempArr(1) Else For i = 1 To UBound(tempArr) If i = 1 Then result = tempArr(i) Else result = result & " و " & tempArr(i) End If Next i End If GetUniqueColumns = result End Function 2025 اسم التوكيل.xlsm

اللهم أذهب البأس ربّ النّاس، اشف وأنت الشّافي، لا شفاء إلا شفاؤك، شفاءً لا يغادر سقماً، أذهب البأس ربّ النّاس، بيدك الشّفاء، لا كاشف له إلّا أنت يارب العالمين. - اللهم إنّي أسألك من عظيم لطفك وكرمك وسترك الجميل، أن تشفيه وتمدّه بالصحّة والعافية، لا ملجأ ولا منجا منك إلّا إليك، إنّك على كلّ شيءٍ قدير

Private Sub cmdSaveTransactions_Click() Call cmdSaveTransactions_Click_Optimized End Sub Private Sub cmdSaveTransactions_Click_Optimized() Dim wsTransactions As Worksheet Set wsTransactions = ThisWorkbook.Sheets("إيرادات ومصروفات") Dim wsCashBox As Worksheet Set wsCashBox = ThisWorkbook.Sheets("صندوق الخزينة") Dim lastRowTransactions As Long Dim i As Long Dim transactionDate As Date Dim transactionAmount As Double Dim dictCashBox As Object ' Dictionary لتخزين بيانات صندوق الخزينة مؤقتًا (التاريخ كمفتاح) Set dictCashBox = CreateObject("Scripting.Dictionary") Dim transactionData As Variant Dim outputArray() As Variant Dim outputRow As Long Dim lastRowCashBox As Long ' تعطيل تحديث الشاشة والأحداث والحساب Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual ' الحصول على آخر صف في شيت الإيرادات والمصروفات lastRowTransactions = wsTransactions.Cells(Rows.Count, "A").End(xlUp).Row + 1 ' حفظ البيانات من الليست بوكس إلى شيت الإيرادات والمصروفات (كما كان) For i = 0 To ListBox1.ListCount - 1 wsTransactions.Cells(lastRowTransactions + i, 1).Value = ListBox1.List(i, 0) wsTransactions.Cells(lastRowTransactions + i, 2).Value = ListBox1.List(i, 1) wsTransactions.Cells(lastRowTransactions + i, 3).Value = ListBox1.List(i, 2) wsTransactions.Cells(lastRowTransactions + i, 4).Value = ListBox1.List(i, 3) wsTransactions.Cells(lastRowTransactions + i, 5).Value = ListBox1.List(i, 4) wsTransactions.Cells(lastRowTransactions + i, 6).Value = ListBox1.List(i, 5) wsTransactions.Cells(lastRowTransactions + i, 7).Value = ListBox1.List(i, 6) Next i ' *** معالجة شيت صندوق الخزينة باستخدام Dictionary لتجميع القيم حسب التاريخ *** ' قراءة البيانات الموجودة في صندوق الخزينة إلى Dictionary lastRowCashBox = wsCashBox.Cells(Rows.Count, "A").End(xlUp).Row If lastRowCashBox > 1 Then transactionData = wsCashBox.Range("A2:D" & lastRowCashBox).Value For i = LBound(transactionData) To UBound(transactionData) Dim dtKey As String: dtKey = Format(transactionData(i, 1), "yyyy-mm-dd") Dim revenueFromSheet As Double: revenueFromSheet = transactionData(i, 3) Dim expenseFromSheet As Double: expenseFromSheet = transactionData(i, 4) Dim previousBalanceFromSheet As Double: previousBalanceFromSheet = transactionData(i, 2) If Not dictCashBox.Exists(dtKey) Then dictCashBox(dtKey) = Array(previousBalanceFromSheet, revenueFromSheet, expenseFromSheet) ' رصيد سابق، إيرادات، مصروفات Else Dim existingData As Variant existingData = dictCashBox(dtKey) existingData(0) = Application.Max(existingData(0), previousBalanceFromSheet) ' نأخذ الرصيد السابق الموجود (قد يكون تراكمي) existingData(1) = existingData(1) + revenueFromSheet existingData(2) = existingData(2) + expenseFromSheet dictCashBox(dtKey) = existingData End If Next i End If ' تحديث Dictionary ببيانات المعاملات الجديدة من الليست بوكس For i = 0 To ListBox1.ListCount - 1 transactionDate = Format(CDate(ListBox1.List(i, 1)), "yyyy-mm-dd") transactionAmount = CDbl(ListBox1.List(i, 5)) Dim revenue As Double: revenue = 0 Dim expense As Double: expense = 0 If ListBox1.List(i, 2) = "إيرادات" Then revenue = transactionAmount ElseIf ListBox1.List(i, 2) = "مصروفات" Then expense = transactionAmount End If If dictCashBox.Exists(transactionDate) Then ' Dim existingData As Variant existingData = dictCashBox(transactionDate) existingData(1) = existingData(1) + revenue existingData(2) = existingData(2) + expense dictCashBox(transactionDate) = existingData Else ' إذا كان التاريخ غير موجود، نحاول الحصول على آخر رصيد سابق من آخر تاريخ في Dictionary (إذا كان موجودًا) Dim lastBalance As Double: lastBalance = 0 If dictCashBox.Count > 0 Then Dim sortedKeys As Variant: sortedKeys = SortDictionaryKeys(dictCashBox) ' دالة لفرز مفاتيح Dictionary lastBalance = dictCashBox(sortedKeys(UBound(sortedKeys)))(0) + dictCashBox(sortedKeys(UBound(sortedKeys)))(1) - dictCashBox(sortedKeys(UBound(sortedKeys)))(2) End If dictCashBox(transactionDate) = Array(lastBalance, revenue, expense) End If Next i ' تحويل Dictionary إلى مصفوفة للإخراج وفرزها حسب التاريخ Dim keys As Variant: keys = dictCashBox.keys ReDim outputArray(1 To dictCashBox.Count, 1 To 4) outputRow = 1 For i = LBound(keys) To UBound(keys) Dim dateValue As Date If IsDate(keys(i)) Then dateValue = CDate(keys(i)) Else Debug.Print "تحذير: مفتاح غير صالح للتاريخ: " & keys(i) dateValue = DateSerial(1900, 1, 1) End If outputArray(outputRow, 1) = dateValue outputArray(outputRow, 3) = dictCashBox(keys(i))(1) ' إيرادات outputArray(outputRow, 4) = dictCashBox(keys(i))(2) ' مصروفات outputRow = outputRow + 1 Next i ' فرز المصفوفة حسب التاريخ If UBound(outputArray, 1) > 0 Then SortArrayByColumn outputArray, 1 End If ' حساب الرصيد السابق وكتابة المصفوفة إلى شيت صندوق الخزينة ReDim finalOutputArray(1 To UBound(outputArray, 1) + 1, 1 To 4) finalOutputArray(1, 1) = "التاريخ" finalOutputArray(1, 2) = "رصيد سابق" finalOutputArray(1, 3) = "رصيد إجمالي اليوم (مدين للإيرادات)" finalOutputArray(1, 4) = "رصيد إجمالي اليوم (دائن للمصروفات)" Dim runningBalance As Double: runningBalance = 0 For i = 1 To UBound(outputArray, 1) finalOutputArray(i + 1, 1) = outputArray(i, 1) finalOutputArray(i + 1, 2) = runningBalance finalOutputArray(i + 1, 3) = outputArray(i, 3) finalOutputArray(i + 1, 4) = outputArray(i, 4) runningBalance = runningBalance + outputArray(i, 3) - outputArray(i, 4) Next i ' مسح البيانات القديمة وكتابة المصفوفة النهائية wsCashBox.Cells.ClearContents wsCashBox.Range("A1").Resize(UBound(finalOutputArray, 1), 4).Value = finalOutputArray wsCashBox.Columns.AutoFit ' إضافة صفوف إجمالي نهاية الشهر (يجب أن يتم بعد كتابة البيانات وفرزها) Call AddMonthlyTotalsToCashBox ' مسح الليست بوكس بعد الحفظ ListBox1.Clear ' ListBox1.AddItem "رقم المسلسل,التاريخ,نوع السند,كود التوريد,اسم التوريد,المبلغ,الملاحظات" TXTSerialNumber.Text = "" ' إعادة تمكين تحديث الشاشة والأحداث والحساب Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic MsgBox "تم حفظ البيانات وتحديث رصيد صندوق الخزينة بنجاح (مع تجميع القيم).", vbInformation End Sub Function SortDictionaryKeys(dict As Object) As Variant Dim arr() As Variant Dim key As Variant Dim i As Long ReDim arr(1 To dict.Count) i = 1 For Each key In dict.keys arr(i) = key i = i + 1 Next key ' فرز المصفوفة حسب التاريخ Dim j As Long, temp As Variant For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) Dim date1 As Date Dim date2 As Date If IsDate(arr(j)) And IsDate(arr(i)) Then date1 = CDate(arr(j)) date2 = CDate(arr(i)) If date1 < date2 Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Else ' معالجة حالة الخطأ إذا لم يكن المفتاح تاريخًا صالحًا (لأغراض التصحيح) Debug.Print "تحذير: مفتاح غير صالح للتاريخ أثناء الفرز: " & arr(i) & " أو " & arr(j) End If Next j Next i SortDictionaryKeys = arr End Function ' دالة مساعدة لفرز مصفوفة ثنائية الأبعاد حسب عمود معين Sub SortArrayByColumn(arr As Variant, col As Long) Dim i As Long, j As Long, temp As Variant For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If arr(j, col) < arr(i, col) Then ' تبديل الصفوف For k = LBound(arr, 2) To UBound(arr, 2) temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If Next j Next i End Sub ' دالة لإضافة صفوف إجمالي نهاية الشهر إلى شيت صندوق الخزينة (يتم استدعاؤها بعد تحديث البيانات) Sub AddMonthlyTotalsToCashBox() Dim wsCashBox As Worksheet Set wsCashBox = ThisWorkbook.Sheets("صندوق الخزينة") Dim lastRow As Long Dim i As Long Dim currentMonth As Long Dim totalRevenue As Double Dim totalExpenses As Double Dim startOfMonthRow As Long lastRow = wsCashBox.Cells(Rows.Count, "A").End(xlUp).Row If lastRow <= 1 Then Exit Sub ' لا توجد بيانات startOfMonthRow = 2 If startOfMonthRow <= lastRow Then currentMonth = Month(wsCashBox.Cells(startOfMonthRow, 1).Value) totalRevenue = 0 totalExpenses = 0 For i = 2 To lastRow Dim nextMonth As Long nextMonth = Month(wsCashBox.Cells(i, 1).Value) totalRevenue = totalRevenue + wsCashBox.Cells(i, 3).Value totalExpenses = totalExpenses + wsCashBox.Cells(i, 4).Value If nextMonth <> currentMonth Then ' إضافة صف الإجمالي للشهر السابق Dim totalBalanceEndOfMonth As Double If i > startOfMonthRow Then totalBalanceEndOfMonth = wsCashBox.Cells(i - 1, 2).Value + Application.WorksheetFunction.Sum(wsCashBox.Range("C" & startOfMonthRow & ":C" & i - 1)) - Application.WorksheetFunction.Sum(wsCashBox.Range("D" & startOfMonthRow & ":D" & i - 1)) Else totalBalanceEndOfMonth = wsCashBox.Cells(startOfMonthRow - 1, 2).Value ' الرصيد السابق إذا كان شهرًا واحدًا فقط End If lastRow = wsCashBox.Cells(Rows.Count, "A").End(xlUp).Row + 1 wsCashBox.Cells(lastRow, 1).Value = "إجمالي شهر " & MonthName(currentMonth) wsCashBox.Cells(lastRow, 2).Value = totalBalanceEndOfMonth wsCashBox.Cells(lastRow, 3).Value = totalRevenue - wsCashBox.Cells(i, 3).Value ' نطرح قيمة الشهر الجديد wsCashBox.Cells(lastRow, 4).Value = totalExpenses - wsCashBox.Cells(i, 4).Value ' نطرح قيمة الشهر الجديد currentMonth = nextMonth totalRevenue = wsCashBox.Cells(i, 3).Value totalExpenses = wsCashBox.Cells(i, 4).Value startOfMonthRow = i End If Next i ' إضافة إجمالي الشهر الأخير بعد انتهاء الحلقة Dim totalBalanceEndOfLastMonth As Double totalBalanceEndOfLastMonth = wsCashBox.Cells(lastRow, 2).Value + Application.WorksheetFunction.Sum(wsCashBox.Range("C" & startOfMonthRow & ":C" & lastRow)) - Application.WorksheetFunction.Sum(wsCashBox.Range("D" & startOfMonthRow & ":D" & lastRow)) lastRow = wsCashBox.Cells(Rows.Count, "A").End(xlUp).Row + 1 wsCashBox.Cells(lastRow, 1).Value = "إجمالي شهر " & MonthName(currentMonth) wsCashBox.Cells(lastRow, 2).Value = totalBalanceEndOfLastMonth wsCashBox.Cells(lastRow, 3).Value = totalRevenue wsCashBox.Cells(lastRow, 4).Value = totalExpenses End If End Sub السلام عليكم ورحمة الله وبركاتة رجاء المسااعدة عند ترحيل المبلغ سواء كان ايرادات او مصروفات يتم تكرار التاريخ وعدم جمع المبلغ فى التاريخ المحدد فى صندوق الخزينة ويتم تكرار التاريخ وتكرار المبلغ سواء ايراد او مصروفات برنامج خزينة ايرادات ومصروفات.xlsm

احسنت والله استاذنا محمد هشام كم انت رائع حقا

تفضل هذا الملف ليس من اعدادى ولاكن من اعداد المحاسب وائل مراد والدعاء له برنامج حضور وإنصراف.xlsالدليل المصور للتعامل مع البرنامج.doc

تفضل جرب هذا Employees Form-unprotected - Copy.xlsm

تفضل جرب هذا الحل باستخدام المعادلات مباشرة في الخلايا: يمكنك وضع المعادلات التالية مباشرة في الخلايا المطلوبة في ورقة "Sheet10": الخلية C3: =G4 الخلية E3: =IF(EOMONTH(C3,6)>G5,G5,EOMONTH(C3,6)) الخلية C4: =E3+1 الخلية E4: =IF(EOMONTH(C4,6)>G5,G5,EOMONTH(C4,6)) الخلية C5: =E4+1 الخلية E5: =IF(EOMONTH(C5,6)>G5,G5,EOMONTH(C5,6)) الخلية C6: =E5+1 الخلية E6: =IF(EOMONTH(C6,6)>G5,G5,EOMONTH(C6,6)) الخلية C7: =E6+1 الخلية E7: =IF(EOMONTH(C7,6)>G5,G5,EOMONTH(C7,6)) الخلية C8: =E7+1 الخلية E8: =IF(EOMONTH(C8,6)>G5,G5,EOMONTH(C8,6)) الخلية C9: =E8+1 الخلية E9: =IF(EOMONTH(C9,6)>G5,G5,EOMONTH(C9,6)) الخلية C10: =E9+1 الخلية E10: =IF(EOMONTH(C10,6)>G5,G5,EOMONTH(C10,6)) شرح المعادلات: EOMONTH(date, months): تقوم هذه الدالة بإرجاع تاريخ نهاية الشهر الذي يقع قبل أو بعد عدد محدد من الأشهر من تاريخ البداية. في حالتنا، نضيف 6 أشهر إلى التاريخ الموجود في العمود C للحصول على نهاية شهر يونيو التالي. IF(logical_test, value_if_true, value_if_false): تقوم هذه الدالة بفحص شرط معين. إذا كان الشرط صحيحًا، فإنها ترجع القيمة الأولى؛ وإلا فإنها ترجع القيمة الثانية. في حالتنا، نتحقق مما إذا كان تاريخ نهاية يونيو أكبر من القيمة الموجودة في الخلية G5. إذا كان أكبر، نكتب قيمة G5؛ وإلا، نكتب تاريخ نهاية يونيو. ملاحظات: تأكد من أن ورقة العمل التي تريد تطبيق الكود أو المعادلات عليها اسمها "Sheet10" بالضبط. إذا كان اسمها مختلفًا، فقم بتعديل اسم الورقة في كود VBA أو عند الإشارة إلى الخلايا في المعادلات. في كود VBA، يتم تنفيذ كل سطر برمجي بشكل منفصل كما طلبت. باستخدام المعادلات، ستتحدث الخلايا تلقائيًا عند تغيير القيم في الخلايا التي تعتمد عليها (مثل G4 أو الخلايا في العمود C). اختر الطريقة التي تناسب احتياجاتك بشكل أفضل. إذا كنت بحاجة إلى تشغيل هذه العمليات بشكل متكرر أو كجزء من عملية أكبر، فقد يكون كود VBA أكثر ملاءمة. أما إذا كانت العملية تتم مرة واحدة أو كنت تفضل عدم استخدام وحدات الماكرو، فإن استخدام المعادلات مباشرة في الخلايا هو خيار جيد. Sub FillCells() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة 10") ' تعيين قيمة الخلية C3 ws.Range("C3").Value = ws.Range("G4").Value ' تعيين معادلة الخلية E3 ws.Range("E3").Formula = "=IF(EOMONTH(C3,6)>G5,G5,EOMONTH(C3,6))" ' تعيين قيمة الخلية C4 ws.Range("C4").Value = ws.Range("E3").Value + 1 ' تعيين معادلة الخلية E4 ws.Range("E4").Formula = "=IF(EOMONTH(C4,6)>G5,G5,EOMONTH(C4,6))" ' تعيين قيمة الخلية C5 ws.Range("C5").Value = ws.Range("E4").Value + 1 ' تعيين معادلة الخلية E5 ws.Range("E5").Formula = "=IF(EOMONTH(C5,6)>G5,G5,EOMONTH(C5,6))" ' تعيين قيمة الخلية C6 ws.Range("C6").Value = ws.Range("E5").Value + 1 ' تعيين معادلة الخلية E6 ws.Range("E6").Formula = "=IF(EOMONTH(C6,6)>G5,G5,EOMONTH(C6,6))" ' تعيين قيمة الخلية C7 ws.Range("C7").Value = ws.Range("E6").Value + 1 ' تعيين معادلة الخلية E7 ws.Range("E7").Formula = "=IF(EOMONTH(C7,6)>G5,G5,EOMONTH(C7,6))" ' تعيين قيمة الخلية C8 ws.Range("C8").Value = ws.Range("E7").Value + 1 ' تعيين معادلة الخلية E8 ws.Range("E8").Formula = "=IF(EOMONTH(C8,6)>G5,G5,EOMONTH(C8,6))" ' تعيين قيمة الخلية C9 ws.Range("C9").Value = ws.Range("E8").Value + 1 ' تعيين معادلة الخلية E9 ws.Range("E9").Formula = "=IF(EOMONTH(C9,6)>G5,G5,EOMONTH(C9,6))" ' تعيين قيمة الخلية C10 ws.Range("C10").Value = ws.Range("E9").Value + 1 ' تعيين معادلة الخلية E10 ws.Range("E10").Formula = "=IF(EOMONTH(C10,6)>G5,G5,EOMONTH(C10,6))" End Sub المصنف (155).xlsm

تفضل جرب هذا ورجاء ادخال مسارات الصورة فى العمود 10 فى شيت DbSheet او من خلال تحديد الاسم فى السجل داخل الليست بوكس وادخال الصورة المدرجة الخاصة بالموظف منظومة-الشؤون-الادارية - Copy - Copy.xlsm

بعد اذن استاذنا المتألق دائما / محمد هشام. تم اضافة المسلسل تلقائى وتم تسجيل تاريخ ووقت التعديل واسم المستخدم تلقائيًا عند تعديل أي سجل في جدول البيانات الخاص بك. فى العمود 8 والعمود 9 منظومة-الشؤون-الادارية - Copy.xlsm

تفضل جرب هذا الحدث 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

تفضل المطلوب ولو اردت استخدام دالة IF لإضافة شروط إضافية، مثل عرض "كيلو" فقط إذا كانت الجرامات صفرًا. هذه المعادلة فى السطر 56 =IF(MOD(SUM(E3:E53);1000)=0;INT(SUM(E3:E53)/1000)+SUM(F3:F53)&" كيلو";INT(SUM(E3:E53)/1000)+SUM(F3:F53)&" كيلو و "&TEXT(MOD(SUM(E3:E53);1000);"0")&" جرام") شغل.xlsx

جرب هذه المعادلة شرح المعادلة ROUND(L4/280*100,1): تقوم هذه الدالة بحساب النسبة المئوية وتقريبها إلى خانة عشرية واحدة. INT(ROUND(L4/280*100,1)): تقوم هذه الدالة بإرجاع الجزء الصحيح من الرقم المقرب. IF(ROUND(L4/280*100,1)=INT(ROUND(L4/280*100,1)),...,...): تقوم هذه الدالة بالتحقق مما إذا كان الرقم المقرب مساويًا للجزء الصحيح منه. إذا كان مساويًا، فهذا يعني أن الرقم صحيح، وإلا فهو عشري. TEXT(ROUND(L4/280*100,1),"0"): إذا كان الرقم صحيحًا، تقوم هذه الدالة بتحويله إلى نص بدون أصفار عشرية. TEXT(ROUND(L4/280*100,1),"0.0"): إذا كان الرقم عشريًا، تقوم هذه الدالة بتحويله إلى نص بخانة عشرية واحدة. مثال إذا كانت L4 تحتوي على 140، فإن الناتج سيكون 50. إذا كانت L4 تحتوي على 141، فإن الناتج سيكون 50.4. آمل أن تكون هذه المعادلة المعدلة تحقق المطلوب. =IF(ROUND(L3/280*100;1)=INT(ROUND(L3/280*100;1));TEXT(ROUND(L3/280*100;1);"0");TEXT(ROUND(L3/280*100;1);"0.0"))

احسنت ا / محمد هشام

وهذا كود معدل لجعل النطاقات في areas تعتمد على LastRow لتكون ديناميكية وتتغير تلقائيًا مع عدد الصفوف في ورقة العمل Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range Dim areas As Range Dim lastRow As Long ' تحديد آخر صف يحتوي على بيانات في العمود C (أو أي عمود آخر يحتوي على بيانات) lastRow = Me.Cells(Me.Rows.Count, "C").End(xlUp).Row ' إعداد النطاقات المتعددة باستخدام LastRow Set areas = Union(Me.Range("C10:L" & lastRow), Me.Range("S10:S" & lastRow), Me.Range("V10:V" & lastRow)) ' التعامل مع تغيير الخلايا On Error GoTo ClearApp Application.EnableEvents = False ' منع اللصق إلا كقيم Set rng = Intersect(Target, areas) If Not rng Is Nothing Then Application.Undo ' التراجع عن اللصق الأصلي For Each cell In rng cell.Value = Target.Value ' لصق القيمة فقط Next cell End If ExitHandler: Application.EnableEvents = True Exit Sub ClearApp: Resume ExitHandler End Sub