使用 Excel VBA 按月拆分合同付款并写入数据库

2026-10-24支付小周

结论

在插入按钮的代码中加入循环。先读取合同总金额、付款次数和首次付款日期，再用 DateAdd("m", ...) 逐月计算付款日期。每循环一次，就在工作表中新增一行记录。

分期金额按货币最小单位舍入，舍入产生的差额计入最后一期，保证所有分期金额之和严格等于合同总金额。

完整代码

以下代码假设数据库结构为：

B 列：客户名称
C 列：本期付款金额
D 列：本期付款日期
第 1 行是表头

Private Sub cmdAdd_Click()

    Dim ws As Worksheet
    Dim iRow As Long
    Dim i As Long
    Dim paymentCount As Long

    Dim totalValue As Currency
    Dim installmentValue As Currency
    Dim currentValue As Currency
    Dim allocatedValue As Currency

    Dim firstPaymentDate As Date
    Dim currentPaymentDate As Date
    Dim clientName As String

    Set ws = ThisWorkbook.Worksheets("Projetos")

    'Validate client name
    clientName = Trim$(Me.boxCliente.Value)

    If clientName = "" Then
        MsgBox "请输入客户名称。", vbExclamation
        Me.boxCliente.SetFocus
        Exit Sub
    End If

    'Validate contract value
    If Not IsNumeric(Me.boxValor.Value) Then
        MsgBox "合同总金额必须是有效数字。", vbExclamation
        Me.boxValor.SetFocus
        Exit Sub
    End If

    totalValue = CCur(Me.boxValor.Value)

    If totalValue <= 0 Then
        MsgBox "合同总金额必须大于 0。", vbExclamation
        Me.boxValor.SetFocus
        Exit Sub
    End If

    'Validate number of payments
    If Not IsNumeric(Me.boxParcela.Value) Then
        MsgBox "付款次数必须是有效整数。", vbExclamation
        Me.boxParcela.SetFocus
        Exit Sub
    End If

    If CDbl(Me.boxParcela.Value) <> Fix(CDbl(Me.boxParcela.Value)) Then
        MsgBox "付款次数不能包含小数。", vbExclamation
        Me.boxParcela.SetFocus
        Exit Sub
    End If

    paymentCount = CLng(Me.boxParcela.Value)

    If paymentCount <= 0 Then
        MsgBox "付款次数必须大于 0。", vbExclamation
        Me.boxParcela.SetFocus
        Exit Sub
    End If

    'Validate first payment date
    If Not IsDate(Me.boxData.Value) Then
        MsgBox "首次付款日期无效。", vbExclamation
        Me.boxData.SetFocus
        Exit Sub
    End If

    firstPaymentDate = CDate(Me.boxData.Value)

    'Calculate regular installment, rounded to two decimal places
    installmentValue = CCur(Application.Round( _
        totalValue / paymentCount, 2))

    allocatedValue = 0

    'Find the next available row based on column B
    iRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row + 1

    'Create one database row for each payment
    For i = 0 To paymentCount - 1

        currentPaymentDate = DateAdd("m", i, firstPaymentDate)

        'Put any rounding difference into the final payment
        If i = paymentCount - 1 Then
            currentValue = totalValue - allocatedValue
        Else
            currentValue = installmentValue
        End If

        With ws
            .Cells(iRow + i, 2).Value = clientName
            .Cells(iRow + i, 3).Value = currentValue
            .Cells(iRow + i, 4).Value = currentPaymentDate
        End With

        allocatedValue = allocatedValue + currentValue

    Next i

    'Apply display formats
    With ws
        .Range(.Cells(iRow, 3), _
               .Cells(iRow + paymentCount - 1, 3)).NumberFormat = "#,##0.00"

        .Range(.Cells(iRow, 4), _
               .Cells(iRow + paymentCount - 1, 4)).NumberFormat = "mm/dd/yyyy"
    End With

    'Clear the form
    Me.boxCliente.Value = ""
    Me.boxValor.Value = ""
    Me.boxParcela.Value = ""
    Me.boxData.Value = ""

    MsgBox paymentCount & " 期付款记录已添加。", vbInformation

End Sub

关键处理逻辑

循环从 0 开始：

For i = 0 To paymentCount - 1

第一期的月份增量是 0，第二期增加一个月，后续各期依次递增：

currentPaymentDate = DateAdd("m", i, firstPaymentDate)

例如，首次付款日期为 01/01/2020，分四期付款时会生成以下日期：

每一期写入的行号也不同：

.Cells(iRow + i, 2).Value = clientName
.Cells(iRow + i, 3).Value = currentValue
.Cells(iRow + i, 4).Value = currentPaymentDate

因此，每次循环都会生成一条独立的数据库记录。

为什么最后一期要单独计算

合同金额不一定能被付款次数整除。例如：

1000 / 3 = 333.333...

如果三期都写入 333.33，合计只有 999.99。代码先写入前两期舍入后的金额，最后一期再用以下公式计算：

currentValue = totalValue - allocatedValue

最终写入的金额为：

333.33
333.33
333.34

三期合计仍是 1000.00。

如果仍要保留“付款次数”列

如果现有表格必须保持以下结构：

B 列：客户
C 列：本期金额
D 列：合同付款次数
E 列：付款日期

请将循环中的写入代码改为：

With ws
    .Cells(iRow + i, 2).Value = clientName
    .Cells(iRow + i, 3).Value = currentValue
    .Cells(iRow + i, 4).Value = paymentCount
    .Cells(iRow + i, 5).Value = currentPaymentDate
End With

日期已经移到 E 列，因此还要把日期格式设置中的列号从 4 改为 5。

注意事项

CDate 会根据当前 Windows 和 Excel 的区域设置解释日期。01/02/2020 既可能被识别为 1 月 2 日，也可能被识别为 2 月 1 日。如果业务固定使用 mm/dd/yyyy，最好使用日期选择控件，或者分别输入年、月、日，再通过 DateSerial 构造日期。

金额文本同样会受到区域设置影响。建议在 boxValor 中只输入数字，例如 1000.00，不要手动输入 $ 或千位分隔符。货币符号可以通过单元格的 NumberFormat 显示。

处理月末日期时，DateAdd 会自动调整不存在的日期。例如，1 月 31 日增加一个月后，可能得到 2 月 28 日；如果是闰年，则可能得到 2 月 29 日。这是 VBA 的正常日期计算规则。如果合同要求付款日始终是每月最后一天，还需要加入月末判断逻辑。