|
|
本帖最后由 VAT2007 于 2015-4-17 16:40 编辑
发一段租赁合同收入的VBA代码，欢迎大家讨论！
（话说我编的租赁合同管理系统，大大简化了原先的租赁会计工作量）
Sub shourujisuan()
Dim endrow As Variant '底行
Dim rightrow As Variant '边行
Dim i As Variant '循环体变量
Dim tianshu As Variant '合同租赁期开始日至各个收入计算月份最后一天的天数，按360天财务系统天数计算
Dim shijitianshu As Variant '合同实际总天数，以一年360日计算，即使用360日财务系统日期
Dim hetong As Variant '合同编码
Dim shouru As Currency '合同收入
Dim riqi As Variant '合同收入计算日期
Dim jieshuriqi As Variant '合同租赁期结束日，包含免租期
Dim kaishiri As Variant '合同租赁期开始日，包含免租期
Dim qijianri As Variant '合同约定按次收款之相应对应租赁期结束日
Dim qijiankaishi As Variant '合同约定按次收款之相应对应租赁期开始日
Dim xuhao As Variant '合同约定按次收款之序号
Dim youxiao As Variant '合同约定按次收款是否在合同有效范围内
Dim qijiantianshu As Variant
Dim fangzhu As Variant '合同约定总房租收入
Dim fangzhuloss As Variant '合同约定总房租收入中因合同终止而损失金额
Dim maxshouru As Variant '合同约定总房租收入减去中因合同终止而损失后金额
Dim test As Currency
Dim test1 As Currency
Dim blt As Variant '计算月份收入所用
Dim bls As Variant '计算月份收入所用
Dim daxunhuan As Variant '循环体变量
Dim ii As Variant '循环体变量
Application.ScreenUpdating = False
riqi = InputBox("请输入收入确认日期!", , "")
riqi = Application.WorksheetFunction.EoMonth(riqi, -1)
daxunhuan = InputBox("请输入收入确认总月份数!", , "")
daxunhuan = daxunhuan + 1
For ii = 1 To daxunhuan
Cells(Rows.Count, 1).Select
Selection.End(xlUp).Select
endrow = ActiveCell.row
Cells(endrow, Columns.Count).Select
Selection.End(xlToLeft).Select
rightrow = ActiveCell.Column
Cells(4, rightrow + 1).Select
Cells(4, rightrow + 1) = riqi
ActiveCell.Offset(1, 0).Select
For i = 1 To endrow - 4
hetong = Cells(ActiveCell.row, 2)
jieshuriqi = Cells(ActiveCell.row, 6)
kaishiri = Cells(ActiveCell.row, 5)
tianshu = Application.WorksheetFunction.Days360(kaishiri, riqi + 1, 0)
shijitianshu = Application.WorksheetFunction.Days360(kaishiri, jieshuriqi + 1, 0)
Worksheets("合同明细").Select
ActiveSheet.Range("A3").Select
Do While Not IsEmpty(ActiveCell)
If hetong = ActiveCell Then
qijianri = Worksheets("合同明细").Cells(ActiveCell.row, 8)
qijiantianshu = Application.WorksheetFunction.Days360(kaishiri, qijianri + 1, 0)
qijiankaishi = Worksheets("合同明细").Cells(ActiveCell.row, 7)
youxiao = Worksheets("合同明细").Cells(ActiveCell.row, 9)
xuhao = Worksheets("合同明细").Cells(ActiveCell.row, 3)
fangzhu = Application.WorksheetFunction.SumIfs(Worksheets("合同明细").Range("F:F"), Worksheets("合同明细").Range("A:A"), hetong)
fangzhuloss = Application.WorksheetFunction.SumIfs(Worksheets("合同变更").Range("e:e"), Worksheets("合同变更").Range("b:b"), hetong)
maxshouru = fangzhu - fangzhuloss
If xuhao = 1 Then
qijiankaishi = kaishiri '此IF语句考虑免租期对收入计算的影响，按会计准则免租期应确认收入
End If
test = Application.WorksheetFunction.Days360(qijiankaishi, riqi + 1, 0)
test1 = Application.WorksheetFunction.Days360(qijiankaishi, qijianri + 1, 0)
If tianshu > qijiantianshu Then
shouru = shouru + Worksheets("合同明细").Cells(ActiveCell.row, 6).Value
Else
If test > 0 Then
shouru = shouru + Round(test / test1 * Worksheets("合同明细").Cells(ActiveCell.row, 6), 2)
End If
End If
shouru = Application.WorksheetFunction.Min(shouru, maxshouru)
If riqi >= jieshuriqi Then
shouru = maxshouru
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
Worksheets("合同收入确认总表").Select
Cells(i + 4, ii + 6).Select
ActiveCell = shouru
shouru = 0
ActiveCell.Offset(1, 0).Select
Next i
riqi = Application.WorksheetFunction.EoMonth(riqi, 1)
Next ii
|
评分
-
1
查看全部评分
-
|
发表于 2015-4-17 16:38:36
发表于 2015-4-18 12:18:02