Excel VBA: функция макроса для расчета графика амортизации дохода по дням

Question

Я пытаюсь написать макрос-функцию, которая будет рассчитывать доход в месяц на основе количества дней в месяце.

Хитрость заключается в расчете даты начала и окончания, как это сделать

Вводимые данные:

• Сумма сделки = Общий доход
• Дата начала сделки
• Дата окончания сделки
• Длительность срока в месяцах
• Формула оборотов в день составляет = (Стоимость сделки / 365) / (Продолжительность срока / 12)

Количество дней рассчитывается дляМесяц, если сделки начинаются в промежутке между Общим числом распознанных доходов, является разницей между Полными днями в датах начала месяца и полными днями месяца.

То же самое с днями окончания контракта, если контракт заканчивается в середине месяца

пример 1

Пример 2

Спасибо, Брайан

Образец файла с двумя вкладками, вкладка 1 имеет пример расчета.Вкладка 2 содержит данные, которые я получаю, а месяцы - это сумма, которую я вычисляю и хочу использовать макрос для автоматизации Ссылка на образец файла Excel

Answer 1

Это решение не VBA, учитывая следующее

1. Значение сделки в столбце A
2. Дата начала сделки в столбце B
3. Дата окончания сделки в столбце C
4. Срок действия в месяцах в D
5. Число оборотов в день в столбце E = = (Стоимость сделки / 365) / (Срок действия / 12)
6. Строка 1 содержит любой день месяца от G1 до CX1

и формула для ввода в G2 и копирования из G2 в CX ... равна

=IF(OR($B2>EOMONTH(G$1,0),$C2<G$1-DAY(G$1)+1),0,IF($C2>EOMONTH(G$1,0),EOMONTH(G$1,0),$C2)-IF($B2>G$1-DAY(G$1)+1,$B2,G$1-DAY(G$1)+1)+1)*$E2

А VBA решение (хотя и не рекомендуется) -

Sub doCalc()
Dim TCVRng As Range, SdtRng As Range, FdtRng As Range, TermLenRng As Range, MonRng As Range
Dim i As Long
'Modify ranges according to your requirement
Set MonRng = ActiveSheet.Range("G1:CX1")
       For i = 2 To 8
    Set TCVRng = ActiveSheet.Cells(i, 1)
    Set SdtRng = ActiveSheet.Cells(i, 2)
    Set FdtRng = ActiveSheet.Cells(i, 3)
    Set TermLenRng = ActiveSheet.Cells(i, 4)
    'Debug.Print TCVRng.Value, SdtRng.Value, FdtRng.Value
    'Debug.Print "============================================="
    'to bypass any intermidate summaty rowrow
       ' If TCVRng.Value > 0 And IsDate(SdtRng.Value) And IsDate(FdtRng.Value) Then
        MonthCal TCVRng, SdtRng, FdtRng, TermLenRng, MonRng
       ' End If
    Next
End Sub

Private Sub MonthCal(TCVRng As Range, SdtRng As Range, FdtRng As Range, TermLenRng As Range, MonRng As Range)
    Dim TCV As Single, Sdt As Date, Fdt As Date, TermLen As Single, PerDay As Single
    Dim Msdt As Date, Medt As Date, MnAmnt As Single, MnDay As Integer
    Dim Cel As Range, Col As Long, ofst As Long
    TCV = TCVRng.Value
    Sdt = SdtRng.Value
    Fdt = FdtRng.Value

    TermLen = TermLenRng.Value
    PerDay = (TCV / 365) / (TermLen / 12)

        For Each Cel In MonRng
        ofst = Cel.Column - TCVRng.Column
        Msdt = Cel.Value
        Msdt = DateAdd("d", -Day(Msdt) + 1, Msdt)
        Medt = DateAdd("m", 1, Msdt)
        Medt = DateAdd("d", -1, Medt)


        MnDay = IIf(Sdt > Medt Or Fdt < Msdt, 0, IIf(Fdt < Medt, Fdt, Medt) - IIf(Sdt > Msdt, Sdt, Msdt) + 1)
        MnAmnt = MnDay * PerDay
        'Debug.Print TCV, Sdt, Fdt, Msdt, Medt, MnDay, MnAmnt
        TCVRng.Offset(, ofst).Value = MnAmnt
        Next Cel
    End Sub