فورم شيت خزينة تكرار التاريخ والمبلغ فى صندوق الخزينة

[mahmoud nasr alhasany]

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

تم تعديل الخميس at 13:44 بواسطه mahmoud nasr alhasany