نجوم المشاركات

وعليكم السلام ورحمة الله وبركاته أخي @ابو نبأ الأمر بسيط جدا وسأشرح لك خطوة بخطوة كيف تضيف شرطا جديدا (مثل: موقع التحميل في العمود k) إلى الكود بحيث يمكنك لاحقا تعديل أو إضافة أي شرط بنفس الطريقة 1) التحقق من أن العمود الجديد (k) ليس فارغا If Trim(WS.Cells(i, "M").Text) <> "" And _ Trim(WS.Cells(i, "L").Text) <> "" And _ Trim(WS.Cells(i, "K").Text) <> "" And _ <===== (موقع التحميل) العمود الجديد 2) تعديل المفتاح M ليشمل القيمة الجديدة m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) & "|" & Trim(WS.Cells(i, "K").Text) 3) تعديل إخراج البيانات المفككة من المفتاح f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 7).Value = Array(f(0), f(1), f(2), a(0), a(1), a(2), a(3)) 4) لا تنسى تعديل رؤوس الأعمدة في الصف الأول لتتناسب مع التغيير dest.Range("A1").Resize(1, 7).Value _ = Array("الشهر", "اسم الشركة", "الموقع", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") ليكون الكود النهائي بعد إظافة عمود موقع التحميل على الشكل التالي Option Explicit Sub TEST2() Dim dest As Worksheet, WS As Worksheet Dim m As String, a As Variant, k As Variant, f As Variant Dim d As Object: Set d = CreateObject("Scripting.Dictionary") Dim ShArr As Variant: ShArr = Array("aaa", "bbb") Dim i As Long, lr As Long, r As Long: r = 2 With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual On Error Resume Next Set dest = Sheets("تقرير مفصل") If dest Is Nothing Then Set dest = Sheets.Add dest.Name = "تقرير مفصل" Else With dest.Range("A:G") .ClearContents .Borders.LineStyle = xlNone End With End If On Error GoTo 0 dest.Range("A1").Resize(1, 7).Value _ = Array("الشهر", "اسم الشركة", "الموقع", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") For Each WS In Sheets(ShArr) If WS.AutoFilterMode Then WS.AutoFilterMode = False lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row For i = 2 To lr If Trim(WS.Cells(i, "M").Text) <> "" And Trim(WS.Cells(i, "L").Text) <> "" And Trim(WS.Cells(i, "K").Text) <> "" Then m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) & "|" & Trim(WS.Cells(i, "K").Text) If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0) d(m) = Array(d(m)(0) + 1, d(m)(1) + tmp(WS.Cells(i, "S").Value), d(m)(2) + tmp(WS.Cells(i, "U").Value), d(m)(3) + tmp(WS.Cells(i, "F").Value)) End If Next i Next WS For Each k In d.Keys f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 7).Value = Array(f(0), f(1), f(2), a(0), a(1), a(2), a(3)) r = r + 1 Next k Call ShFormat(dest, "A:G") .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم إعداد التقرير المفصل بنجاح", vbInformation End Sub "======================================= Private Function tmp(x As Variant) As Double tmp = IIf(IsNumeric(x), x, 0) End Function '======================================= Private Sub ShFormat(ByRef WS As Worksheet, ByVal Col As String) With WS .Activate Dim lastRow As Long lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row With WS.Range("A1:G" & lastRow).Borders .LineStyle = xlDash: .Weight = xlThin: .ColorIndex = xlAutomatic End With .DisplayRightToLeft = True .Columns(Col).EntireColumn.AutoFit .Columns(Col).HorizontalAlignment = xlCenter .Columns(Col).VerticalAlignment = xlBottom .Range("E:G").NumberFormat = "0" End With End Sub ملاحظة : يمكنك تعطيل تنسيق الجدول النهائي بحذف أو تعليق هذا السطر أو تعديله ليشمل أعمدة أكثر إذا زادت الأعمدة لاحقا Call ShFormat(dest, "A:G") تقرير - حسب - الشهر - والشركة -الموقعV2 .xlsm

اخي ريان نحاول المساعدة ولكنك لم تكلف نفسك بادراج ملف PDF الموجود لديك لنرى التصميم لديك ولا قاعدة بياناتك ( انت ادرجت لنا مرة اخرى قاعدة بيانات الاستاذ @kkhalifa1960 لنقل بيانات من الاكسس الى PDF : اولا يجب ان يكون لديك برنامج برنامج Adobe Acrobat Pro (وليس Adobe Reader فقط) او برنامج PDFtk ثانيا ملف PDF يجب ان يكون استمارة فردية اي لعرض بيانات فردية وليس نموذج مستمر كما ارفقت انت في مثال اخونا خليفة ثالثا تفعيل المرجع Adobe Acrobat xx.x Type Library (xx = رقم الإصدار مثل 10.0 أو 11.0) رابعا يجب أن يحتوي ملف الـ PDF على الحقول المسماة مثلا : وهذه يم اضافتها عن طريق البرامج المذكورة في اولا "Text1" "Dropdown2" "todaysDate" خامسا استخدام هذه الشيفرة اذا كان البرنامج المستخدم PDFtk ::::::::::::::::::::::::: Sub FillPDF() Dim tempFDF As String Dim pdfInput As String Dim pdfOutput As String Dim shellCmd As String Dim fso As Object Dim fdfContent As String Dim pdftkPath As String Dim appPath As String ' تحديد مسار البرنامج الحالي (نفس مجلد قاعدة البيانات أو ملف الإكسل) appPath = Application.CurrentProject.Path ' Access ' إذا كنت تستخدم Excel بدلاً من Access، استبدل بالسطر التالي: ' appPath = ThisWorkbook.Path ' تحديد مسار الملفات pdfInput = appPath & "\template.pdf" ' اسم ملف PDF بجانب الملف pdfOutput = appPath & "\output_filled.pdf" ' ملف الإخراج بجانب الملف tempFDF = appPath & "\temp_data.fdf" ' ملف FDF مؤقت ' مسار برنامج PDFtk pdftkPath = """C:\Program Files (x86)\PDFtk Server\bin\pdftk.exe""" ' تحضير محتوى FDF fdfContent = "%FDF-1.2" & vbCrLf fdfContent = fdfContent & "1 0 obj<</FDF<< /Fields[" & _ "<< /T (Text1) /V (" & Me.Text0.Value & ") >>" & _ "<< /T (Dropdown2) /V (" & Me.Text2.Value & ") >>" & _ "<< /T (todaysDate) /V (" & Me.Text4.Value & ") >>" & _ "] >> >>endobj" & vbCrLf fdfContent = fdfContent & "trailer<</Root 1 0 R>>" & vbCrLf fdfContent = fdfContent & "%%EOF" ' إنشاء ملف FDF Set fso = CreateObject("Scripting.FileSystemObject") With fso.CreateTextFile(tempFDF, True) .Write fdfContent .Close End With ' تنفيذ الأمر باستخدام PDFtk shellCmd = pdftkPath & " """ & pdfInput & """ fill_form """ & tempFDF & """ output """ & pdfOutput & """ flatten" Shell shellCmd, vbHide MsgBox "تم إنشاء الملف: " & pdfOutput End Sub سادسا استخدام هذه الشيفرة اذا كان البرنامج المستخدم Adobe Acrobat Pro ::::::::::::::::::::::::: Dim AcroApp As Acrobat.CAcroApp Dim theForm As Acrobat.CAcroPDDoc Dim jso As Object Dim path As String Dim field As Object Dim Text1, Dropdown2, todaysDate As String Dim Text0, Text2, Text4 As String Set AcroApp = CreateObject("AcroExch.App") Set theForm = CreateObject("AcroExch.PDDoc") theForm.Open (Me.Label16.Caption) Set jso = theForm.GetJSObject 'write the values to corresponding pdf fields jso.getfield("Text1").Value = Me.Text0.Value jso.getfield("Dropdown2").Value = Me.Text2.Value jso.getfield("todaysDate").Value = Me.Text4.Value theForm.Save PDSaveIncremental, Me.Label16.Caption theForm.Close AcroApp.Exit Set AcroApp = Nothing Set theForm = Nothing سابعا ::: انا دوري انتهى هنا بارك الله فيك

السلام عليكم حسب فهمى لطلبك وبدون ارفاق ملف منكم اليك الكود Sub RunMacroWithPassword() Dim password As String Dim userInput As String password = "1234" userInput = InputBox("من فضلك أدخل كلمة السر لتشغيل الماكرو:", "كلمة السر") If userInput = password Then MsgBox "كلمة السر صحيحة، سيتم الآن تشغيل الماكرو.", vbInformation Call MyProtectedMacro Else MsgBox "كلمة السر غير صحيحة. لن يتم تشغيل الماكرو.", vbCritical End If End Sub Sub MyProtectedMacro() MsgBox "تم تشغيل الماكرو بنجاح!", vbInformation ' أضف الكود الحقيقي هنا... End Sub الكود الاول Sub RunMacroWithPassword() وفيه المطالبة بكلمة السر وهي 1234 والكود الثاني Sub MyProtectedMacro() وهو الذي سيتم تنفيذه بعد وضع كلمة السر مثال تنفيذ ماكرو مع ادخال كلمة سر.xlsb

اعرض الملف ⚙🛠🎁 أداة لإصلاح وتعديل النصوص العربية التالفة في الأكواد .. من > ÇáÓáÇã Úáíßã إلى > السلام عليكم :: السلام عليكم ورحمة الله وبركاته :: نظرا لوجود مشكلة عند نسخ النصوص العربية في أكواد VBA وخصوصا عندما تكون لغة النظام معينة على اللغة الإنجليزية .. لذلك قمت بتصميم هذه الأداة لتقوم بإصلاح العبارات العربية التالفة في الكود وإرجاعها إلى أصلها ... مثال : ÇáÓáÇã Úáíßã >>>> تعود لأصلها : السلام عليكم وهذه صورة للأداة : صاحب الملف Moosak تمت الاضافه 04/22/25 الاقسام قسم الأكسيس  

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

الطريقة الجديدة تختلف عن القديمة لا يمكنك عرض الفصلين افقيا .. معا بل كالمتبع في التقارير الحالية .. النموذج نفسه ,, يعرض فصل دراسي واحد حسب التصفية

تفضل استاذ @moho58 طلبك حسب مافهمت . ووافني بالرد . BASE_P-1.rar

dest.Range("A11:T" & Lr).ClearContents =========> dest.Range("A11:Y" & Lr).ClearContents Private Sub ShFormat(ByRef dest As Worksheet, ByVal Col As String) Dim lastRow As Long lastRow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row With dest.Range("A11:Y" & lastRow).Borders .LineStyle = xlDash: .Weight = xlThin: .ColorIndex = xlAutomatic End With End Sub Dim Lr As Long: Lr = dest.Rows.Count With dest.Range("A11:Y" & Lr) .ClearContents: .Borders.LineStyle = xlNone End With عمالة نظام 2025_2026.xlsm

ملاحظة القاعدة المرفقة لديك لم يتم التحميل ...... عملت لك قاعدة وفيها بيانات راجع جدول التوزيع هل تم بالشكل المطلوب ام لا ............... NA_1.accdb

لم افهم ما المقصود بالتنسيق وان كنت تقصد العمود الاخير M غير ظاهر في ملف PDF فاستبدل في الكود نطاق البيانات Range("A1:L" & lastRow).ExportAsFixedFormat _ بهذا المدى Range("A1:M" & lastRow).ExportAsFixedFormat _ يعتى بدل العمود L يصبح M عمالة نظام جديد2025_2026.xlsm

السلام عليكم ورحمة الله وبركاته اليك ما طلبت عمالة نظام جديد3.36.xlsm

السلام عليكم ورحمة الله وبركاته Sub حذفالكومة() Dim c As Range Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual: Application.EnableEvents = False For Each c In ActiveSheet.UsedRange If VarType(c.Value) = vbString Then Dim txt As String: txt = Trim(c.Value) If Left(txt, 1) = "'" Then txt = Mid(txt, 2) If Right(txt, 1) = "'" Then txt = Left(txt, Len(txt) - 1) If txt <> c.Value Then c.NumberFormat = "@": c.Value = txt End If Next c Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic: Application.EnableEvents = True End Sub ازالة علامة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Option Compare Text Sub FilterContractorData() Dim CrWS As Worksheet, dest As Worksheet, OnRng, ColArr, a(1 To 4) Const tmp1 = 3, tmp2 = 4, colDate = 1 Set CrWS = Sheets("يومية المقاولين") Set dest = Sheets("تقرير تفصيلى") With Application .ScreenUpdating = False: .Calculation = xlCalculationManual OnRng = CrWS.Range("B8:Y" & CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row).Value a(1) = dest.[D3].Value: a(2) = dest.[E3].Value a(3) = dest.[C6].Value: a(4) = dest.[D6].Value ColArr = FiltreTbl(OnRng, a, tmp1, tmp2, colDate, _ Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24)) If Not IsEmpty(ColArr) Then Dim Lr As Long: Lr = dest.Rows.Count dest.Range("A11:T" & Lr).ClearContents dest.Range("B11").Resize(UBound(ColArr), UBound(ColArr, 2)).Value = ColArr With dest.Range("A11:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-10") End With Else MsgBox "لا توجد بيانات تطابق الشروط المحددة", vbExclamation End If .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub Function FiltreTbl(OnRng, a, tmp1, tmp2, colDate, Optional f) Dim cnt(), temp(), b(), n&, j&, i&, k&, r&, vDate n = UBound(OnRng, 2) If IsMissing(f) Then ReDim cnt(0 To n - 1): For k = 0 To n - 1: cnt(k) = k + 1: Next k Else: cnt = f End If j = UBound(cnt): ReDim temp(1 To UBound(OnRng), 1 To j + 1) For i = LBound(OnRng) To UBound(OnRng) vDate = OnRng(i, colDate) If IsDate(vDate) And (a(1) = "" Or OnRng(i, tmp1) = a(1)) And (a(2) = "" Or OnRng(i, tmp2) = a(2)) _ And (vDate >= a(3) And vDate <= a(4)) Then r = r + 1: For k = 0 To j: temp(r, k + 1) = OnRng(i, cnt(k)): Next k End If Next i If r > 0 Then ReDim b(1 To r, 1 To j + 1) For i = 1 To r: For k = 1 To j + 1: b(i, k) = temp(i, k): Next k: Next i FiltreTbl = b Else: FiltreTbl = Empty End If End Function عمالة نظام جديد.xlsm

تفضل أخي Sub test() Dim dest As Worksheet, WS As Worksheet Dim m As String, a As Variant, k As Variant, f As Variant Dim d As Object: Set d = CreateObject("Scripting.Dictionary") Dim ShArr As Variant: ShArr = Array("aaa", "bbb") Dim i As Long, lr As Long, r As Long: r = 2 With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual On Error Resume Next Set dest = Sheets("التقرير") If dest Is Nothing Then Set dest = Sheets.Add: dest.Name = "التقرير" Else dest.Range("A:F").ClearContents On Error GoTo 0 dest.Range("A1").Resize(1, 6).Value _ = Array("الشهر", "اسم الشركة", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") For Each WS In Sheets(ShArr) If WS.AutoFilterMode Then WS.AutoFilterMode = False lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row For i = 2 To lr If Trim(WS.Cells(i, "M").Text) <> "" And Trim(WS.Cells(i, "L").Text) <> "" Then m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0) d(m) = Array(d(m)(0) + 1, d(m)(1) + tmp(WS.Cells(i, "S").Value), _ d(m)(2) + tmp(WS.Cells(i, "U").Value), d(m)(3) + tmp(WS.Cells(i, "F").Value)) End If Next i Next WS For Each k In d.Keys f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 6).Value = Array(f(0), f(1), a(0), a(1), a(2), a(3)) r = r + 1 Next k .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم إعداد التقرير بنجاح", vbInformation End Sub Private Function tmp(x As Variant) As Double tmp = IIf(IsNumeric(x), x, 0) End Function الشهر والشركة.xlsm

من المتطلبات .. ضبط العمليات الاربع بحيث تجري بسلاسة وتخدم المستخدم .. اعمل 4 ازرار او تبويبات : بيع / شرائ / مرتجع بيع / مرتجع شراء الفورم يفتح افتراضيا على البيع .. لأن 90% من العمليات هي بيع حينها يكون حقل نوع العملية ( بيع ) اجباريا ، ويتم تصفية قائمة العملاء فلا يظهر الا الزبائن فقط وحين تنقر على زر شراء : حينها يكون حقل نوع العملية ( شراء ) اجباريا ، ويتم تصفية قائمة العملاء فلا يظهر الا الموردون فقط وينطبق هذا على الزرين الآخرين ايضا من اجل الاحصاءات والاستعلامات مستقبلا ( وهو غير ملزم ) ادراج حقلي العميل ونوع العملية ضمن جدول التفاصيل

رداً للجميل في هذا المتدى المتميز، أرفق إليكم هذا الملف لإدارة الميزانية الشخصية، والذي استخدمت فيه دالة pivotable ودمجتها بدالة filter ، وتم عرض الملف بداش بورد جميل ومرتب.. تحياتي للجميع. الميزانية الشخصية.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ضع هدا في حدث ورقة معلمين Option Explicit Private Const ShName As String = "معلمين" Private Sub Worksheet_Calculate() Static tmps As Boolean If tmps Then Exit Sub tmps = True If Not IsEmpty(Me.Range("D5").Value) Then Coloring_Classes tmps = False End Sub Sub Coloring_Classes() Dim Sh As Worksheet: Set Sh = ThisWorkbook.Sheets(ShName) On Error GoTo HandleError Application.ScreenUpdating = False: Application.EnableEvents = False Application.Calculation = xlCalculationManual xColor Sh, Sh.[D5].Value, "C7:I11" xColor Sh, Sh.[D18].Value, "C20:I24" xColor Sh, Sh.[D30].Value, "C32:I36" Cleanup: Application.ScreenUpdating = True: Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Exit Sub HandleError: Resume Cleanup End Sub Sub xColor(ws As Worksheet, Search As String, cnt As String) Dim xCell As Range, xRng As Long, OnRng As Range, ky As Variant Dim r As Long, c As Long, n() As Long Set OnRng = ws.Range(cnt) If Trim(Search) = "" Then: OnRng.Interior.ColorIndex = xlColorIndexNone: Exit Sub Set xCell = ws.Range("Q2:Q" & ws.Cells(ws.Rows.Count, "Q").End(xlUp).Row) _ .Find(What:=Search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) If xCell Is Nothing Then: OnRng.Interior.ColorIndex = xlColorIndexNone: Exit Sub xRng = xCell.Offset(0, 1).Interior.Color ky = OnRng.Value ReDim n(1 To UBound(ky, 1), 1 To UBound(ky, 2)) For r = 1 To UBound(ky, 1) For c = 1 To UBound(ky, 2) If Not IsError(ky(r, c)) And Len(Trim(ky(r, c))) > 0 Then n(r, c) = xRng End If Next c Next r OnRng.Interior.ColorIndex = xlColorIndexNone For r = 1 To UBound(n, 1) For c = 1 To UBound(n, 2) If n(r, c) <> 0 Then OnRng.Cells(r, c).Interior.Color = n(r, c) End If Next c Next r End Sub جدول التفريغ V2.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

وعليكم السلام ورحمة الله وبركاته الطريفة الاولى قبل حفظ الملف ارجع الى الصفحة الرئيسية ثم حفظ الطريقة الثاتية عن طريق كود وسيقوم بفتح الصفحة الرئيسية حتى لو قمت بالحفظ عند ورقة 10 مثلا ضع هذا الكود في محرر الاكود في ThisWorkbook Private Sub Workbook_Open() Sheets("SHEET1").Activate End Sub طبعا غير اسم SHEET1 بالكود باسم الشيت الرئيسى لديك