中国会计视野论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

微信登录

微信扫一扫,快速登录

查看: 3091|回复: 5

讨论EXCEL之VBA财务应用:发一段租赁合同收入的VBA代码

[复制链接]
发表于 2015-4-17 16:38:36 | 显示全部楼层 |阅读模式
  2021翻开新篇章,5折考取CMA认证
CMA最新资讯号“CMA订阅号”上线
IMA-复旦大学校园管理会计案例大赛启动
CMA是您挖掘职业潜能的通关秘钥
 

视野思享会年费会员
一年内免费直播参与
历届活动视频回放
与爱学习群体共同成长

 

欢迎订阅会计视野微信公众号
第一时间了解最新财会知识
碎片化学习新方法
200万读者追随的真爱选择。

本帖最后由 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-18 12:18:02 | 显示全部楼层
会VB,但老是不会VBA,对与EXCLE里的接口不熟
发表于 2015-4-18 12:50:48 | 显示全部楼层
何不发一个excel表来
发表于 2015-4-18 16:05:55 | 显示全部楼层
凿齿 发表于 2015-4-18 12:18
会VB,但老是不会VBA,对与EXCLE里的接口不熟

点啊点啊的就熟了,常用的就那么几个对象方法属性,太麻烦的用vba也不划算
发表于 2019-5-28 14:21:30 | 显示全部楼层
你好,我看见你在论坛发的贴子关于《租赁合同管理系统》计算合同收入的vba,能不能发一份excel给我学习参考一下呢?谢谢!QQ邮箱:32155722@qq.com
发表于 2021-1-11 10:55:34 | 显示全部楼层
劳烦楼主能否将Excel版本发出来供我们学习参考一下,多谢!
您需要登录后才可以回帖 登录 | 注册

本版积分规则

手机版|中国会计视野论坛 ( 沪ICP备05013522号-2 )

GMT+8, 2021-1-23 03:56

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表