توزيع الاقساط الشهرية

[ابوبكر علي عمر]

السلام عليكم ورحمة الله وبركاته

ارجو منكم مساعدتي في توزيع الاقساط على عدد الشهور مع مراعاة الكسور في التاريخ

جدول توزيع الاقساط.xlsx

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله وبركانه

اولا لديك حساب المدة غير دقيق  

فمثلا  1/1/2024 - 31/12/2024 ليست 12 شهر ينقصها يوم وبكن يمكن اعتبارها 12 شهر 

20-3-2024 - 31-12-2024 ليست  9  اشهر و37 يوم كما ورد في ملفك والصحيح 9 اشهر و11 يوم

تم عمل كود يقوم بتوزيع المبلغ  على عدد الاشهر وفي حالة وجود ايام مع الاشهر يدخلها قي توزيغ الميلغ

حالات استنائية مثل حالة 11شهر و30 يوم سينم نوزيعها على 12 شهر

هذا حسب قهمى لطلبك وانمنى ان يكون الملف المرفق فيه طلبك  

الكود

Sub توزيع()
    Dim ws As Worksheet
    Dim startDate As Range, endDate As Range, amount As Range
    Dim i As Long, monthsDiff As Integer, extraDays As Integer
    Dim totalMonths As Integer, monthlyAmount As Double
    Dim colStart As Integer
        Range("H7:S12").ClearContents

    Set ws = ThisWorkbook.Sheets("ورقة1")
    Set startDate = ws.Range("D7:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row)
    Set endDate = ws.Range("E7:E" & ws.Cells(ws.Rows.Count, "E").End(xlUp).Row)
    Set amount = ws.Range("F7:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row)
    
    colStart = 8
    
    For i = 1 To startDate.Rows.Count
        If IsDate(startDate.Cells(i, 1).Value) And IsDate(endDate.Cells(i, 1).Value) Then
            Dim startDt As Date, endDt As Date
            startDt = startDate.Cells(i, 1).Value
            endDt = endDate.Cells(i, 1).Value
            
            monthsDiff = DateDiff("m", startDt, endDt)
            If Day(endDt) < Day(startDt) Then
                monthsDiff = monthsDiff - 1
                extraDays = Day(endDt) + (Day(DateSerial(Year(endDt), Month(endDt), 0)) - Day(startDt))
            Else
                extraDays = Day(endDt) - Day(startDt)
            End If
            
            If extraDays >= 30 Then
                monthsDiff = monthsDiff + 1
            End If
            
            If IsNumeric(amount.Cells(i, 1).Value) And amount.Cells(i, 1).Value > 0 Then
                If monthsDiff > 0 Then
                    monthlyAmount = amount.Cells(i, 1).Value / monthsDiff
                    
                    Dim j As Integer
                    For j = 0 To monthsDiff - 1
                        ws.Cells(i + 6, colStart + j).Value = monthlyAmount
                    Next j
                Else
                    ws.Cells(i + 6, colStart).Value = ""
                End If
            Else
                ws.Cells(i + 6, colStart).Value = ""
            End If
        Else
            ws.Cells(i + 6, colStart).Value = ""
        End If
    Next i
End Sub

جدول توزيع الاقساط.xlsm