mahmoud nasr alhasany

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

السلام عليكم ورحمة الله وبركاتة ممكن مساعدتى فضلا وليس امرا فى ربط الموقع مع المخزن بحيث عند اختيار مخزن معين يتم ربطها بالعميل او الموقع فى فاتورة البيع invoiceSale وايضا عمل تقرير صنف مع المخزن بين تاريخين وتقرير كشف حساب عميل وتقرير كشف حساب مورد برنامج مخازن ومبيعات ومشتروات.mdb

لقد صممت بداية المشروع واضافات التسميات رجاء التكملة مخزن محاسبى - Copy.xlsm

حد الطلب وتاريخ الصلاحية معاً عند فتح الملف أو عند استدعائه يدوياً. ضع هذا الكود في Module عام: Sub CheckReorderLevels() Dim wsSetup As Worksheet: Set wsSetup = Sheets("Setup") Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim lastRowSetup As Long, i As Long Dim currentBal As Double, reorderLevel As Double Dim itemName As String Dim lowStockMsg As String, expiryMsg As String Dim monthsLimit As Integer: monthsLimit = 3 lastRowSetup = wsSetup.Cells(wsSetup.Rows.Count, 2).End(xlUp).Row lowStockMsg = "" expiryMsg = "" ' 1. فحص حد الطلب (بناءً على الأرصدة الحالية) For i = 2 To lastRowSetup itemName = wsSetup.Cells(i, 2).Value ' اسم الصنف من شيت Setup reorderLevel = wsSetup.Cells(i, 4).Value ' حد الطلب من شيت Setup ' حساب الرصيد الإجمالي للصنف من شيت الحركات (الوارد - الصادر) currentBal = Application.WorksheetFunction.SumIf(wsTrans.Range("E:E"), itemName, wsTrans.Range("I:I")) - _ Application.WorksheetFunction.SumIf(wsTrans.Range("D:D"), itemName, wsTrans.Range("I:I")) If currentBal <= reorderLevel Then lowStockMsg = lowStockMsg & "- " & itemName & " (الرصيد: " & currentBal & " / حد الطلب: " & reorderLevel & ")" & vbCrLf End If Next i ' 2. فحص تواريخ الصلاحية (أقل من 3 أشهر) Dim lastRowTrans As Long lastRowTrans = wsTrans.Cells(wsTrans.Rows.Count, 1).End(xlUp).Row For i = 2 To lastRowTrans ' افترضنا أن تاريخ الصلاحية في العمود رقم 10 (J) والكمية في 9 (I) If IsDate(wsTrans.Cells(i, 10).Value) And wsTrans.Cells(i, 9).Value > 0 Then If DateDiff("m", Date, wsTrans.Cells(i, 10).Value) <= monthsLimit And wsTrans.Cells(i, 10).Value >= Date Then expiryMsg = expiryMsg & "- " & wsTrans.Cells(i, 6).Value & " (ينتهي في: " & wsTrans.Cells(i, 10).Value & ")" & vbCrLf End If End If Next i ' --- إظهار التنبيهات للمستخدم --- If lowStockMsg <> "" Then MsgBox "⚠️ أصناف وصلت لحد الطلب:" & vbCrLf & lowStockMsg, vbExclamation, "تنبيه المخزون" End If If expiryMsg <> "" Then MsgBox "📅 أصناف تقترب صلاحيتها من الانتهاء:" & vbCrLf & expiryMsg, vbCritical, "تنبيه الصلاحية" End If End Sub

1. تصميم نموذج الإدخال (UserForm) قم بإنشاء UserForm جديد في محرر VBA (Alt + F11) وقم بتسمية العناصر كالتالي: ComboBox1: لنوع الحركة (إضافة، صرف، تحويل، شراء، بيع). ComboBox2: للمخزن (المصدر/الرئيسي). ComboBox3: للمخزن (الهدف - يظهر فقط في حالة التحويل). ComboBox4: للصنف. ComboBox5: للوحدة. ComboBox6: للحالة (جديد، مستعمل، تالف). TextBox1: للكمية. Listbox1 : عرض البيانات CommandButton1: زر "ترحيل CommandButton2: زر "حفظ Private Sub UserForm_Initialize() Dim wsSetup As Worksheet Set wsSetup = Sheets("Setup") Dim lastRow As Long ' 1. تعبئة أنواع الحركة يدوياً ComboBox1.List = Array("إضافة", "صرف", "تحويل", "شراء", "بيع") ' 2. تعبئة المخازن من شيت Setup (العمود A) lastRow = wsSetup.Cells(wsSetup.Rows.Count, 1).End(xlUp).Row ComboBox2.List = wsSetup.Range("A2:A" & lastRow).Value ' من مخزن ComboBox3.List = wsSetup.Range("A2:A" & lastRow).Value ' إلى مخزن ' 3. تعبئة الأصناف من شيت Setup (العمود B) lastRow = wsSetup.Cells(wsSetup.Rows.Count, 2).End(xlUp).Row ComboBox4.List = wsSetup.Range("B2:B" & lastRow).Value ' 4. تعبئة الوحدات والحالات بنفس الطريقة ComboBox5.List = Array("قطعة", "كيلو", "كرتونة") ComboBox6.List = Array("جديد", "مستعمل", "تالف") ' تحديث ListBox لعرض آخر الحركات UpdateListBox End Sub الحركة". Private Sub ComboBox1_Change() ' إذا كانت الحركة تحويل، أظهر خانة المخزن المحول إليه If ComboBox1.Value = "تحويل" Then ComboBox3.Visible = True Label_ToStore.Visible = True ' افترضنا أنك وضعت عنواناً بجانبه Else ComboBox3.Visible = False Label_ToStore.Visible = False ComboBox3.Value = "" ' مسح القيمة إذا لم تكن تحويلاً End If End Sub Sub UpdateListBox() Dim ws As Worksheet Set ws = Sheets("Transactions") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' ضبط عدد الأعمدة في ListBox With ListBox1 .ColumnCount = 5 .ColumnWidths = "60;60;80;80;50" ' عرض آخر 5 صفوف فقط (إذا توفرت) If lastRow > 5 Then .List = ws.Range("A" & lastRow - 4 & ":E" & lastRow).Value ElseIf lastRow > 1 Then .List = ws.Range("A2:E" & lastRow).Value End If End With End Sub Private Sub BtnSearch_Click() Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim rowNum As Long Dim searchText As String searchText = TxtSearch.Value ' خانة البحث عن رقم الإذن On Error Resume Next ' البحث عن رقم الإذن في العمود الثاني (رقم الإذن) rowNum = Application.Match(CLng(searchText), ws.Columns(2), 0) On Error GoTo 0 If rowNum > 0 Then ' تعبئة الخانات بالبيانات الموجودة في الشيت ComboBox1.Value = ws.Cells(rowNum, 2).Value ' نوع الحركة ComboBox2.Value = ws.Cells(rowNum, 3).Value ' من مخزن ' ... استكمل لبقية الخانات ... TextBox1.Value = ws.Cells(rowNum, 8).Value ' الكمية ' تخزين رقم الصف في Label مخفي للرجوع إليه عند التعديل LblRowNumber.Caption = rowNum MsgBox "تم جلب البيانات، يمكنك تعديلها الآن", vbInformation Else MsgBox "رقم الإذن غير موجود", vbExclamation End If End Sub Private Sub BtnUpdate_Click() Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim rowNum As Long rowNum = Val(LblRowNumber.Caption) ' استرجاع رقم الصف المخزن If rowNum > 1 Then ws.Cells(rowNum, 2).Value = ComboBox1.Value ws.Cells(rowNum, 3).Value = ComboBox2.Value ws.Cells(rowNum, 5).Value = ComboBox4.Value ws.Cells(rowNum, 8).Value = CDbl(TextBox1.Value) MsgBox "تم تحديث البيانات بنجاح", vbInformation UpdateListBox ' تحديث القائمة لرؤية التعديل End If End Sub Function GetNextSerial() As Long Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row If lastRow < 2 Then GetNextSerial = 1001 ' يبدأ الترقيم من هذا الرقم Else GetNextSerial = ws.Cells(lastRow, 2).Value + 1 End If End Function Function ConvertToBox(ItemName As String, TotalPieces As Double) As String Dim wsSetup As Worksheet: Set wsSetup = Sheets("Setup") Dim PackSize As Integer Dim Boxes As Integer, Remainder As Integer Dim cell As Range ' البحث عن سعة كرتونة الصنف في شيت Setup Set cell = wsSetup.Range("B:B").Find(ItemName, LookIn:=xlValues, LookAt:=xlWhole) If Not cell Is Nothing Then PackSize = cell.Offset(0, 1).Value ' السعة موجودة في العمود التالي If PackSize > 0 Then Boxes = Int(TotalPieces / PackSize) ' عدد الكراتين الكاملة Remainder = TotalPieces Mod PackSize ' القطع المتبقية ConvertToBox = Boxes & " كرتونة و " & Remainder & " قطعة" Else ConvertToBox = TotalPieces & " قطعة" End If Else ConvertToBox = TotalPieces & " قطعة" End If End Function Private Sub TxtQty_Change() On Error Resume Next If TxtQty.Value <> "" And ComboBox4.Value <> "" Then ' تحديث العنوان بالتحويل التلقائي LblPackingInfo.Caption = ConvertToBox(ComboBox4.Value, CDbl(TxtQty.Value)) Else LblPackingInfo.Caption = "" End If End Sub Sub RefreshInventoryReport() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim wsInv As Worksheet: Set wsInv = Sheets("Inventory_Summary") Dim lastRow As Long, i As Long ' مسح البيانات القديمة wsInv.Range("A2:E1000").ClearContents ' استخدام Pivot Table خلفي أو مجموع شرطي لجلب الأرصدة ' هنا سنفترض أنك تريد جلب الأصناف الفريدة المتاحة ' كود مبسط لجلب الأرصدة: lastRow = wsTrans.Cells(wsTrans.Rows.Count, 5).End(xlUp).Row ' كود افتراضي لجمع الكميات (يفضل استخدام PivotTable لسرعة أكبر في البيانات الضخمة) ' ولكن هنا سنستخدم الدالة التي برمجناها سابقاً للتحويل ' مثال لتعبئة الصف الأول (كمثال توضيحي): Dim totalQty As Double: totalQty = 150 ' هذا الرقم يأتي من SUMIFS Dim itemName As String: itemName = "صنف A" wsInv.Range("A2").Value = itemName wsInv.Range("D2").Value = totalQty ' استخدام الدالة التي صممناها في الخطوة السابقة wsInv.Range("E2").Value = ConvertToBox(itemName, totalQty) End Sub Private Sub ComboBox4_Change() Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim CurrentStock As Double Dim ItemName As String: ItemName = ComboBox4.Value Dim StoreName As String: StoreName = ComboBox2.Value ' المخزن المختار ' حساب الرصيد الحالي برمجياً باستخدام WorksheetFunction CurrentStock = Application.WorksheetFunction.SumIfs(ws.Range("I:I"), ws.Range("F:F"), ItemName, ws.Range("D:D"), StoreName) - _ Application.WorksheetFunction.SumIfs(ws.Range("I:I"), ws.Range("F:F"), ItemName, ws.Range("C:C"), StoreName) ' عرض النتيجة للمستخدم مع التحويل للكراتين LblCurrentBalance.Caption = "الرصيد المتاح في هذا المخزن: " & ConvertToBox(ItemName, CurrentStock) End Sub Private Sub BtnSave_Click() Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim CurrentStock As Double Dim ItemName As String: ItemName = ComboBox4.Value Dim StoreName As String: StoreName = ComboBox2.Value Dim RequestedQty As Double: RequestedQty = CDbl(TxtQty.Value) ' فحص إذا كانت الحركة (صرف، بيع، أو تحويل صادر) If ComboBox1.Value = "صرف" Or ComboBox1.Value = "بيع" Or ComboBox1.Value = "تحويل" Then ' حساب الرصيد الحالي في هذا المخزن تحديداً CurrentStock = Application.WorksheetFunction.SumIfs(ws.Range("I:I"), ws.Range("F:F"), ItemName, ws.Range("D:D"), StoreName) - _ Application.WorksheetFunction.SumIfs(ws.Range("I:I"), ws.Range("F:F"), ItemName, ws.Range("C:C"), StoreName) ' المقارنة بين المتاح والمطلوب If RequestedQty > CurrentStock Then MsgBox "عذراً.. الرصيد غير كافٍ في " & StoreName & vbCrLf & _ "الرصيد المتاح هو: " & CurrentStock & " قطعة فقط.", vbCritical, "تنبيه أمان المخزن" Exit Sub ' إيقاف عملية الحفظ End If End If ' ... بقية كود الترحيل والحفظ الذي كتبناه سابقاً ... End Sub Private Sub TxtQty_Change() ' كود إضافي لتحسين تجربة المستخدم On Error Resume Next ' (بافتراض أنك حسبت CurrentStock مسبقاً) If CDbl(TxtQty.Value) > CurrentStock Then TxtQty.BackColor = vbRed TxtQty.ForeColor = vbWhite Else TxtQty.BackColor = vbWhite TxtQty.ForeColor = vbBlack End If End Sub Private Sub Workbook_Open() Dim wsSetup As Worksheet: Set wsSetup = Sheets("Setup") Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim lastRow As Long, i As Long Dim currentBal As Double, reorderLevel As Double Dim itemName As String, msg As String lastRow = wsSetup.Cells(wsSetup.Rows.Count, 1).End(xlUp).Row msg = "الأصناف التالية وصلت لحد الطلب أو أقل:" & vbCrLf For i = 2 To lastRow itemName = wsSetup.Cells(i, 2).Value reorderLevel = wsSetup.Cells(i, 4).Value ' حساب الرصيد الإجمالي للصنف في كل المخازن currentBal = Application.WorksheetFunction.SumIfs(wsTrans.Range("I:I"), wsTrans.Range("F:F"), itemName) - _ Application.WorksheetFunction.SumIfs(wsTrans.Range("I:I"), wsTrans.Range("F:F"), itemName) ' (تعديل بسيط حسب هيكلة مخازنك) If currentBal <= reorderLevel Then msg = msg & "- " & itemName & " (الرصيد الحالي: " & currentBal & ")" & vbCrLf End If Next i If msg <> "الأصناف التالية وصلت لحد الطلب أو أقل:" & vbCrLf Then MsgBox msg, vbExclamation, "تنبيه نقص المخزون" End If End Sub ' يوضع هذا الكود بعد ترحيل حركة الصرف مباشرة في زر الحفظ If (CurrentStock - RequestedQty) <= reorderLevel Then MsgBox "تنبيه: الصنف " & ItemName & " أصبح رصيده منخفضاً جداً!", vbInformation End If Private Sub BtnSave_Click() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim wsSetup As Worksheet: Set wsSetup = Sheets("Setup") Dim nextRow As Long, CurrentStock As Double, ReorderLevel As Double ' --- 1. التحقق من الرصيد (أمان المخزن) --- If ComboBox1.Value = "صرف" Or ComboBox1.Value = "بيع" Or ComboBox1.Value = "تحويل" Then CurrentStock = Application.WorksheetFunction.SumIfs(wsTrans.Range("I:I"), wsTrans.Range("F:F"), ComboBox4.Value, wsTrans.Range("D:D"), ComboBox2.Value) - _ Application.WorksheetFunction.SumIfs(wsTrans.Range("I:I"), wsTrans.Range("F:F"), ComboBox4.Value, wsTrans.Range("C:C"), ComboBox2.Value) If CDbl(TxtQty.Value) > CurrentStock Then MsgBox "عذراً! الرصيد غير كافٍ. المتاح: " & CurrentStock, vbCritical: Exit Sub End If End If ' --- 2. ترحيل البيانات --- nextRow = wsTrans.Cells(wsTrans.Rows.Count, 1).End(xlUp).Row + 1 With wsTrans .Cells(nextRow, 1).Value = Date .Cells(nextRow, 2).Value = TxtSerial.Value .Cells(nextRow, 3).Value = ComboBox1.Value ' نوع الحركة .Cells(nextRow, 4).Value = ComboBox2.Value ' من مخزن .Cells(nextRow, 5).Value = ComboBox3.Value ' إلى مخزن .Cells(nextRow, 6).Value = ComboBox4.Value ' الصنف .Cells(nextRow, 8).Value = ComboBox6.Value ' الحالة .Cells(nextRow, 9).Value = CDbl(TxtQty.Value) End With ' --- 3. تنبيه حد الطلب بعد العملية --- ' (كود إضافي لفحص حد الطلب من شيت Setup) MsgBox "تمت العملية بنجاح!", vbInformation Unload Me: UserForm1.Show End Sub Private Sub Workbook_Open() ' هنا نضع الكود الذي يمسح الأصناف ويقارن أرصدتها بحد الطلب ' ويظهر رسالة تحذيرية إذا كان (الرصيد <= حد الطلب) Call CheckReorderLevels End Sub Sub CheckExpiryDates() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim lastRow As Long, i As Long Dim expiryDate As Date Dim msg As String Dim monthsLimit As Integer: monthsLimit = 3 lastRow = wsTrans.Cells(wsTrans.Rows.Count, 1).End(xlUp).Row msg = "تنبيه: الأصناف التالية ستنتهي صلاحيتها خلال 3 أشهر:" & vbCrLf For i = 2 To lastRow ' التحقق من وجود تاريخ صلاحية في العمود J If IsDate(wsTrans.Cells(i, 10).Value) Then expiryDate = wsTrans.Cells(i, 10).Value ' حساب الفرق بين تاريخ اليوم وتاريخ الصلاحية ' DateDiff("m", ...) يحسب الفرق بالشهور If DateDiff("m", Date, expiryDate) <= monthsLimit And expiryDate >= Date Then msg = msg & "- " & wsTrans.Cells(i, 6).Value & " (تنتهي في: " & expiryDate & ")" & vbCrLf End If End If Next i If msg <> "تنبيه: الأصناف التالية ستنتهي صلاحيتها خلال 3 أشهر:" & vbCrLf Then MsgBox msg, vbExclamation, "مراقبة الصلاحية" End If End Sub Private Sub TxtExpiry_Exit(ByVal Cancel As MSForms.ReturnBoolean) If TxtExpiry.Value <> "" Then If Not IsDate(TxtExpiry.Value) Then MsgBox "يرجى إدخال التاريخ بصيغة صحيحة (DD/MM/YYYY)", vbCritical Cancel = True End If End If End Sub Sub ExportExpiryReportToPDF() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim wsTemp As Worksheet Dim lastRow As Long, i As Long, targetRow As Long Dim fileName As String ' إنشاء شيت مؤقت للتقرير Set wsTemp = Worksheets.Add wsTemp.Name = "Expiry_Report_Temp" ' وضع العناوين wsTemp.Range("A1:D1").Value = Array("الصنف", "المخزن", "الكمية", "تاريخ الصلاحية") wsTemp.Range("A1:D1").Font.Bold = True targetRow = 2 lastRow = wsTrans.Cells(wsTrans.Rows.Count, 1).End(xlUp).Row ' فلترة الأصناف التي ستنتهي خلال 90 يوم For i = 2 To lastRow If IsDate(wsTrans.Cells(i, 10).Value) Then If wsTrans.Cells(i, 10).Value - Date <= 90 And wsTrans.Cells(i, 10).Value >= Date Then wsTemp.Cells(targetRow, 1).Value = wsTrans.Cells(i, 6).Value ' الصنف wsTemp.Cells(targetRow, 2).Value = wsTrans.Cells(i, 4).Value ' المخزن wsTemp.Cells(targetRow, 3).Value = wsTrans.Cells(i, 9).Value ' الكمية wsTemp.Cells(targetRow, 4).Value = wsTrans.Cells(i, 10).Value ' الصلاحية targetRow = targetRow + 1 End If End If Next i ' تنسيق الجدول wsTemp.Columns("A:D").AutoFit ' مسار الحفظ (سطح المكتب) fileName = Environ("USERPROFILE") & "\Desktop\تقرير_الصلاحية_" & Format(Date, "yyyy-mm-dd") & ".pdf" ' تصدير إلى PDF wsTemp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fileName ' حذف الشيت المؤقت Application.DisplayAlerts = False wsTemp.Delete Application.DisplayAlerts = True MsgBox "تم تصدير تقرير PDF بنجاح إلى سطح المكتب باسم: " & vbCrLf & fileName, vbInformation End Sub Sub ExportExpiryToWord() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim objWord As Word.Application Dim objDoc As Word.Document Dim objTable As Word.Table Dim i As Long, lastRow As Long, targetRow As Long ' إنشاء تطبيق Word جديد Set objWord = New Word.Application objWord.Visible = True ' جعل الوورد مرئياً Set objDoc = objWord.Documents.Add ' إضافة عنوان للمستند With objWord.Selection .Font.Size = 18 .Font.Bold = True .ParagraphFormat.Alignment = wdAlignParagraphCenter .TypeText "تقرير الأصناف التي تقترب صلاحيتها من الانتهاء" .TypeParagraph .Font.Size = 12 .Font.Bold = False .ParagraphFormat.Alignment = wdAlignParagraphRight .TypeText "تاريخ التقرير: " & Date .TypeParagraph: .TypeParagraph End With ' حساب عدد الصفوف التي تنطبق عليها الشروط أولاً لتحديد حجم الجدول lastRow = wsTrans.Cells(wsTrans.Rows.Count, 1).End(xlUp).Row targetRow = 1 ' إضافة جدول (بشكل مبدئي بصف واحد للعناوين) Set objTable = objDoc.Tables.Add(objWord.Selection.Range, 1, 4) objTable.Borders.Enable = True objTable.Cell(1, 1).Range.Text = "الصنف" objTable.Cell(1, 2).Range.Text = "المخزن" objTable.Cell(1, 3).Range.Text = "الكمية" objTable.Cell(1, 4).Range.Text = "تاريخ الصلاحية" objTable.Rows(1).Range.Font.Bold = True objTable.Rows(1).Shading.BackgroundPatternColor = wdColorGray10 ' ملء الجدول بالبيانات المفلترة For i = 2 To lastRow ' فحص الصلاحية (أقل من 90 يوم) If IsDate(wsTrans.Cells(i, 10).Value) Then If wsTrans.Cells(i, 10).Value - Date <= 90 And wsTrans.Cells(i, 10).Value >= Date Then objTable.Rows.Add targetRow = objTable.Rows.Count objTable.Cell(targetRow, 1).Range.Text = wsTrans.Cells(i, 6).Value objTable.Cell(targetRow, 2).Range.Text = wsTrans.Cells(i, 4).Value objTable.Cell(targetRow, 3).Range.Text = wsTrans.Cells(i, 9).Value objTable.Cell(targetRow, 4).Range.Text = wsTrans.Cells(i, 10).Value End If End If Next i ' رسالة تأكيد MsgBox "تم إنشاء مستند Word وتصدير البيانات بنجاح!", vbInformation End Sub Sub UndoTransfer() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim transID As Variant Dim foundRow As Variant Dim confirm As VbMsgBoxResult ' طلب رقم الإذن المراد التراجع عنه transID = InputBox("يرجى إدخال رقم الإذن (التحويل) المراد التراجع عنه:", "تراجع عن عملية") If transID = "" Then Exit Sub ' إلغاء في حال لم يتم إدخال رقم ' البحث عن رقم الإذن في العمود الثاني foundRow = Application.Match(CLng(transID), wsTrans.Columns(2), 0) If IsError(foundRow) Then MsgBox "عذراً، رقم الإذن غير موجود!", vbCritical Exit Sub End If ' التأكد أن العملية هي "تحويل" If wsTrans.Cells(foundRow, 3).Value <> "تحويل" Then MsgBox "هذا الإذن ليس عملية تحويل، لا يمكن التراجع عنه بهذا الزر!", vbExclamation Exit Sub End If ' تأكيد الحذف confirm = MsgBox("هل أنت متأكد من التراجع عن هذا التحويل؟" & vbCrLf & _ "سيتم حذف السجل وإعادة الكمية للمخزن المصدر.", vbQuestion + vbYesNo, "تأكيد") If confirm = vbYes Then wsTrans.Rows(foundRow).Delete MsgBox "تم التراجع عن العملية بنجاح وتحديث المخزون.", vbInformation ' تحديث أي قوائم أو تقارير مفتوحة Call UpdateListBox End If End Sub Sub UndoTransferWithAudit() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim wsAudit As Worksheet: Set wsAudit = Sheets("Audit_Log") Dim transID As Variant Dim foundRow As Variant Dim nextAuditRow As Long transID = InputBox("أدخل رقم الإذن للتراجع عنه:", "نظام الرقابة") If transID = "" Then Exit Sub ' البحث عن السجل foundRow = Application.Match(CLng(transID), wsTrans.Columns(2), 0) If Not IsError(foundRow) Then ' 1. تسجيل البيانات في سجل المراقبة قبل الحذف nextAuditRow = wsAudit.Cells(wsAudit.Rows.Count, 1).End(xlUp).Row + 1 With wsAudit .Cells(nextAuditRow, 1).Value = Now ' التاريخ والوقت الحالي .Cells(nextAuditRow, 2).Value = wsTrans.Cells(foundRow, 2).Value ' رقم الإذن .Cells(nextAuditRow, 3).Value = wsTrans.Cells(foundRow, 6).Value ' الصنف .Cells(nextAuditRow, 4).Value = wsTrans.Cells(foundRow, 9).Value ' الكمية .Cells(nextAuditRow, 5).Value = wsTrans.Cells(foundRow, 4).Value ' المخزن المصدر .Cells(nextAuditRow, 6).Value = Application.UserName ' اسم مستخدم الكمبيوتر .Cells(nextAuditRow, 7).Value = "تراجع/حذف تحويل" End With ' 2. تنفيذ الحذف الفعلي wsTrans.Rows(foundRow).Delete MsgBox "تم التراجع وتسجيل العملية في سجل الرقابة.", vbInformation Else MsgBox "رقم الإذن غير موجود!", vbCritical End If End Sub Sub FillUndoList() Dim ws As Worksheet: Set ws = Sheets("Transactions") Dim lastRow As Long, i As Long ListBox2.Clear ListBox2.ColumnCount = 4 ListBox2.ColumnWidths = "50;80;80;50" ' رقم الإذن، الصنف، من، إلى lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row ' عرض آخر 10 حركات تحويل فقط لسهولة التراجع For i = lastRow To 2 Step -1 If ws.Cells(i, 3).Value = "تحويل" Then With ListBox2 .AddItem ws.Cells(i, 2).Value ' رقم الإذن .List(.ListCount - 1, 1) = ws.Cells(i, 6).Value ' اسم الصنف .List(.ListCount - 1, 2) = ws.Cells(i, 4).Value ' من مخزن .List(.ListCount - 1, 3) = ws.Cells(i, 9).Value ' الكمية End With End If If ListBox2.ListCount > 10 Then Exit For Next i End Sub Private Sub CommandButton_Undo_Click() Dim wsTrans As Worksheet: Set wsTrans = Sheets("Transactions") Dim wsAudit As Worksheet: Set wsAudit = Sheets("Audit_Log") Dim transID As Long Dim foundRow As Variant Dim nextAuditRow As Long ' التأكد من اختيار حركة من القائمة If ListBox2.ListIndex = -1 Then MsgBox "يرجى اختيار حركة من القائمة أولاً!", vbExclamation Exit Sub End If ' الحصول على رقم الإذن من العمود الأول في الـ ListBox transID = ListBox2.List(ListBox2.ListIndex, 0) ' البحث عن السجل في شيت الحركات foundRow = Application.Match(transID, wsTrans.Columns(2), 0) If Not IsError(foundRow) Then ' 1. تسجيل العملية في الـ Audit Log المخفي nextAuditRow = wsAudit.Cells(wsAudit.Rows.Count, 1).End(xlUp).Row + 1 wsAudit.Cells(nextAuditRow, 1).Value = Now wsAudit.Cells(nextAuditRow, 2).Value = transID wsAudit.Cells(nextAuditRow, 6).Value = Application.UserName wsAudit.Cells(nextAuditRow, 7).Value = "تراجع عبر اليوزرفورم" ' 2. حذف السجل wsTrans.Rows(foundRow).Delete MsgBox "تم التراجع عن التحويل رقم " & transID & " بنجاح.", vbInformation ' 3. تحديث القائمة فوراً Call FillUndoList End If End Sub

من يساعدنى فى عمل برنامج محاسبى بيع شراء تحويل الدليل المختصر هو ما يضمن استمرارية العمل وحماية النظام من سوء الاستخدام. إليك دليل المستخدم الموحد المصمم ليوضع في شيت باسم "التعليمات" أو يطبع للموظفين: 📘 دليل مستخدم برنامج إدارة المخازن الاحترافي 1️⃣ تسجيل حركة جديدة (إضافة / تحويلات / بيع / شراء) افتح لوحة التحكم واضغط على زر "إضافة حركة". سيقوم البرنامج بإنشاء رقم إذن تلقائي وتاريخ اليوم. اختر نوع الحركة؛ سيقوم النظام بتكييف الخيارات بناءً على اختيارك. اختر المخزن ثم الصنف. سيظهر لك "الرصيد المتاح" فوراً أسفل الصنف. أدخل الكمية؛ إذا تجاوزت الرصيد المتاح في عمليات الصرف، سيتحول لون الخانة للأحمر ويمنعك النظام من الحفظ. اضغط حفظ؛ سيتم ترحيل البيانات وتحديث التقارير فوراً. 2️⃣ عملية التحويل بين المخازن عند اختيار نوع الحركة "تحويل"، سيظهر لك تلقائياً خانة "المخزن المحول إليه". تأكد من اختيار مخزن المصدر (من) ومخزن الهدف (إلى). سيقوم البرنامج بخصم الكمية من الأول وإضافتها للثاني في خطوة واحدة. 3️⃣ التراجع عن العمليات (التصحيح) من داخل اليوزرفورم، انتقل إلى قائمة "التراجع عن الحركات". ستظهر لك قائمة بآخر 10 تحويلات تمت. حدد الحركة التي تريد إلغاءها من القائمة واضغط "تراجع عن الحركة". تنبيه: أي عملية تراجع يتم تسجيلها سرياً في "سجل المراقبة" باسم المستخدم ووقت الحذف. 4️⃣ إدارة تواريخ الصلاحية وحد الطلب عند إدخال صنف جديد، تأكد من إدخال تاريخ الصلاحية. عند فتح الملف، سيعطيك البرنامج تنبيهاً تلقائياً بالأصناف التي ستنتهي خلال 3 أشهر. إذا قل رصيد صنف عن "حد الطلب" المعرف في الإعدادات، سيظهر لك تنبيه بضرورة إعادة الشراء. 5️⃣ استخراج التقارير جرد المخازن: يعطيك الأرصدة الحالية مقسمة (كرتونة / قطعة). كرت الصنف: لمتابعة حركة صنف معين في فترة زمنية محددة. تصدير التقرير: يمكنك تصدير تقارير الصلاحية والنواقص بضغطة زر إلى PDF للإرسال أو Word للتعديل. ⚠️ تعليمات هامة للمدير: تحديث البيانات: لإضافة صنف جديد أو مخزن جديد، اذهب لشيت Setup وأضفه في القائمة. كلمة المرور: لا تشارك كلمة مرور محرر VBA مع الموظفين لضمان عدم عبثهم بالأكواد. الأمان: شيت Audit_Log مخفي تماماً؛ يمكنك الإطلاع عليه من خلال محرر الأكواد فقط لمراقبة عمليات الحذف. هل اكتملت الصورة لديك الآن؟

الف شكر استاذنا / عبدالله بشير عبدالله عندك حق لقد نسيت اضافة البحث فى العمود (G3:U3)

السلام عليكم ورحمة الله وبركاتة الرجاء مساعدتى فى التعديل على هذا الكود طريقة عمل الكود هو ان الهدف الرئيس ينقل وتنسيق البيانات (Data Transformation): يقوم الكود بالبحث عن قيم مطابقة في عمود (W4:W117) ورؤوس أعمدة مطابقة في صف (Y3:AM3)، واستخراج القيم المتقاطعة من جدول مصدر آخر (D4:U...) ولصق النتائج كقيم ثابتة في النطاق (Y4:AM...).التقنية الأساسيةالعمل بالمصفوفات (Arrays): يتم تحميل جميع البيانات (المصدر، قيم البحث، ورؤوس الأعمدة) إلى الذاكرة. تتم عمليات البحث والمعالجة داخل المصفوفات، ويتم لصق النتائج مرة واحدة فقط في نهاية الكود، مما يزيد السرعة بشكل كبير ويقلل من تفاعلات Excel البطيئة.التنظيف والمعالجةيتضمن الكود وظيفة مسبقة لمسح نطاق النتائج القديم (ClearDataRange)، كما يقوم بـ تنظيف النصوص (إزالة المسافات الزائدة وغير القابلة للكسر) لضمان دقة المطابقة، ويتجاهل القيم الصفرية والفارغة عند اللصق.ورقة العمل يستهدف ورقة عمل محددة باسم "الرصيد 3". ولكن المشكلة ان يوجد اصناف بالرغم من مطابقتها مع الاصناف الاخرى لا يتم ترحيل الكمية وفقا لتاريخ التابع لها فما السبب اما بعض الاصناف تعمل بكفائة الكود :- Sub Alternative_CalculateAndPasteValues2() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("الرصيد 3") ' غيّر Dim sourceData As Variant Dim lookupValues As Variant Dim colHeaders As Variant Dim resultArray As Variant Dim i As Long, j As Long, k As Long Dim foundRow As Long, foundCol As Long Call ClearDataRange ' Load all data into arrays for speed sourceData = ws.Range("D4:U" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row).Value lookupValues = ws.Range("W4:W117").Value colHeaders = ws.Range("Y3:AM3").Value ' Resize the result array ReDim resultArray(1 To UBound(lookupValues, 1), 1 To UBound(colHeaders, 2)) ' Loop through the lookup values For i = 1 To UBound(lookupValues, 1) Dim currentLookupValue As String currentLookupValue = Trim(Replace(lookupValues(i, 1), Chr(160), " ")) ' Manual loop to find the matching row foundRow = 0 For k = 1 To UBound(sourceData, 1) Dim cleanedSourceValue As String cleanedSourceValue = Trim(Replace(sourceData(k, 1), Chr(160), " ")) If StrComp(cleanedSourceValue, currentLookupValue, vbTextCompare) = 0 Then foundRow = k Exit For End If Next k ' If a matching row is found If foundRow > 0 Then ' Loop through the columns For j = 1 To UBound(colHeaders, 2) Dim currentHeader As String currentHeader = Trim(Replace(colHeaders(1, j), Chr(160), " ")) ' Manual loop to find the matching column (on the G:U headers) foundCol = 0 Dim m As Long For m = 1 To 15 ' G to U is 15 columns Dim cleanedHeader As String cleanedHeader = Trim(Replace(ws.Cells(3, m + 6).Value, Chr(160), " ")) If StrComp(cleanedHeader, currentHeader, vbTextCompare) = 0 Then foundCol = m Exit For End If Next m ' If a matching column is found If foundCol > 0 Then Dim resultValue As Variant resultValue = sourceData(foundRow, foundCol + 3) ' +3 to correct for D-G offset ' Place the result in the array, handling zeros and blanks If IsNumeric(resultValue) And CDbl(resultValue) <> 0 Then resultArray(i, j) = resultValue Else resultArray(i, j) = "" End If End If Next j End If Next i ' Paste the final array to the worksheet in one go ws.Range("Y4").Resize(UBound(resultArray, 1), UBound(resultArray, 2)).Value = resultArray End Sub Sub ClearDataRange() ' Clears the contents (data) from the range A4:AM125 Range("Y4:AM125").ClearContents End Sub تنسيق ترتيب الجداول الكمية مع اسم الصنف مع التاريخ التابع له - Copy - Copy.xlsm

الف شكر ا/ hegazee على مساعدته لهذه المشكله

هذا الكود الصحيح بخصوص تنسيق الاعمدة المختلفة من العمود 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

وهذا الكود الى اخر بيانات مدرجه وليس نطاق معين .Range("A6:AH75").Sort Key1:=.Range("L6:L75"), Order1:=xlDescending, Header:=xlNo .Range("A6:AH75").Sort Key1:=.Range("L6:L75"), Order1:=xlDescending, Header:=xlNo Sub ترتيب_وعرض_أرصدة_العملاء() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim totalDebt As Double Set ws = ThisWorkbook.Sheets("ورقة1") With ws ' 1. تحديد LastRow lastRow = .Cells(.Rows.Count, "L").End(xlUp).Row ' 2. ترتيب البيانات تنازليًا حسب رصيد العميل باستخدام LastRow .Range("A6:AH" & lastRow).Sort Key1:=.Range("L6:L" & lastRow), Order1:=xlDescending, Header:=xlNo ' 3. إخفاء الصفوف التي تحتوي على أرصدة غير موجبة أو تساوي صفرًا For i = 6 To lastRow If .Cells(i, "L").Value <= 0 Then .Rows(i).Hidden = True Else .Rows(i).Hidden = False End If Next i ' 4. حساب إجمالي المديونية باستخدام LastRow totalDebt = WorksheetFunction.SumIf(.Range("L6:L" & lastRow), ">0") ' 5. عرض إجمالي المديونية وتنسيقها .Range("AH1").Value = totalDebt .Range("AH1").NumberFormat = "#,##0.00 ""ج.م""" ' تنسيق مخصص ' 6. تنسيق الخلية AI1 With .Range("AI1") .Font.Color = RGB(255, 0, 0) .Font.Bold = True .Value = "إجمالي المديونية: " & totalDebt End With End With End Sub