Excel VBAで業務効率アップ！収入・経費を自動按分化し誤差処理も自動化で業務を効率化する方法（テクニック）

Excel VBAで業務効率アップ！収入・経費を自動按分化し誤差処理も自動化で業務を効率化する方法（テクニック）

Excel VBAで業務を簡単に！予算按分の自動化方法

'
'
Sub distribution01()

    Dim TotalAmount, TotalRatio, ApportionedValue, AdjustedTotal, ErrorValue, MaxValue As Double
    Dim RangeToApportion, Cell, MaxCell As Range
    Dim LastRow As Long

    ' 合計金額をセル「D1」から取得
    TotalAmount = Range("D1").Value

    ' 最終行を取得
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row

    ' 按分する範囲を設定（C列の4行目から最終行まで）
    Set RangeToApportion = Range("C4:C" & LastRow)

    ' 合計比率を計算
    TotalRatio = Application.Sum(RangeToApportion)

    ' 初期化
    MaxValue = 0
    Set MaxCell = Nothing

    ' 各セルに按分（小数点以下切り捨て）し、最大値を特定
    For Each Cell In RangeToApportion
        ApportionedValue = WorksheetFunction.Floor((Cell.Value / TotalRatio) * TotalAmount, 1)
        ' 金額をD列に出力
        Cells(Cell.Row, "D").Value = ApportionedValue
        AdjustedTotal = AdjustedTotal + ApportionedValue

        ' 最大値の更新
        If ApportionedValue > MaxValue Then
            MaxValue = ApportionedValue
            Set MaxCell = Cell
        End If
    Next Cell

    ' 誤差を計算
    ErrorValue = TotalAmount - AdjustedTotal

    ' 一番金額の大きいセルに誤差を加算
    If Not MaxCell Is Nothing Then
        Cells(MaxCell.Row, "D").Value = Cells(MaxCell.Row, "D").Value + ErrorValue
    End If
End Sub
'
'

EXCEL VBA　比率に基づく金額按分の自動化・財務管理を強化する効率的な資金分配方法の実装

EXCEL VBAで実現する財務分析：収入・経費・人件費の按分テクニック・同時に複数の収支を按分・配分する。

'
'
Sub distribution03()
    ' 変数宣言
    Dim TotalIncome, TotalExpense, TotalPayroll As Double
    Dim IncomeRatio, ExpenseRatio, PayrollRatio As Double
    Dim IncomeError, ExpenseError, PayrollError As Double
    Dim IncomeMax, ExpenseMax, PayrollMax As Double
    Dim IncomeMaxCell, ExpenseMaxCell, PayrollMaxCell As Range
    Dim Cell As Range
    Dim LastRow As Long

    ' 初期金額を取得
    TotalIncome = Range("C2").Value
    TotalExpense = Range("D2").Value
    TotalPayroll = Range("E2").Value

    ' 最終行を特定
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row

    ' 最大値とセルの初期化
    IncomeMax = 0
    ExpenseMax = 0
    PayrollMax = 0
    Set IncomeMaxCell = Nothing
    Set ExpenseMaxCell = Nothing
    Set PayrollMaxCell = Nothing

    ' 各行の按分処理
    For Each Cell In Range("B5:B" & LastRow)
        ' 按分率の取得
        IncomeRatio = Cell.Value / 100
        ExpenseRatio = Cell.Value / 100
        PayrollRatio = Cell.Value / 100

        ' 収入、経費、人件費を按分
        Cells(Cell.Row, "C").Value = WorksheetFunction.Floor(TotalIncome * IncomeRatio, 1)
        Cells(Cell.Row, "D").Value = WorksheetFunction.Floor(TotalExpense * ExpenseRatio, 1)
        Cells(Cell.Row, "E").Value = WorksheetFunction.Floor(TotalPayroll * PayrollRatio, 1)

        ' 最大値の更新
        If Cells(Cell.Row, "C").Value > IncomeMax Then
            IncomeMax = Cells(Cell.Row, "C").Value
            Set IncomeMaxCell = Cell
        End If
        If Cells(Cell.Row, "D").Value > ExpenseMax Then
            ExpenseMax = Cells(Cell.Row, "D").Value
            Set ExpenseMaxCell = Cell
        End If
        If Cells(Cell.Row, "E").Value > PayrollMax Then
            PayrollMax = Cells(Cell.Row, "E").Value
            Set PayrollMaxCell = Cell
        End If
    Next Cell

    ' 誤差の調整
    IncomeError = TotalIncome - Application.Sum(Range("C5:C" & LastRow))
    ExpenseError = TotalExpense - Application.Sum(Range("D5:D" & LastRow))
    PayrollError = TotalPayroll - Application.Sum(Range("E5:E" & LastRow))

    ' 誤差を最大値を持つセルに加算
    If Not IncomeMaxCell Is Nothing Then
        Cells(IncomeMaxCell.Row, "C").Value = Cells(IncomeMaxCell.Row, "C").Value + IncomeError
    End If
    If Not ExpenseMaxCell Is Nothing Then
        Cells(ExpenseMaxCell.Row, "D").Value = Cells(ExpenseMaxCell.Row, "D").Value + ExpenseError
    End If
    If Not PayrollMaxCell Is Nothing Then
        Cells(PayrollMaxCell.Row, "E").Value = Cells(PayrollMaxCell.Row, "E").Value + PayrollError
    End If
End Sub
'
'