关于VBA技术在合并财务报表合并抵消中的应用

syzlove

关于VBA技术在合并财务报表合并抵消中的应用

1.背景介绍
在某大型国企从事合并报表编制工作2年，纯财务出身，技术背景仅限于大学阶段考过VF二级，参加工作后纯粹凭借个人兴趣自学，在利用vba技术自动化配对抵消方面略有心得，也有不少困惑，在此献丑，希望能跟相关从业爱好者共同交流学习！

内部往来、内部交易和内部现金流抵消，是编制合并报表工作的重要工作。本集团合并范围200多家，内部往来规模大约四五百亿。信息化方面，本集团尚未建立对账平台，财务软件用金蝶，在合并抵消这块，财务软件能做的就是把下级单位内部往来、内部交易和内部现金流数据（以下简称内部数据）汇总到一起，给你配好对，提供了取大、取小、取平均和手工指定等方式去处理对账差异，但整体上感觉并不好用。存在的问题主要是：内部数据的完整性依赖各基层财务人员素质和责任心，校验成本和沟通成本高昂，虽然可以通过管理手段加以改善，但能用技术手段根治的，就坚决不让人去做。
2.解决思路（以内部往来为例）
大致的思路包括汇总、配对、抵消、输出四个步骤
（1）汇总：直接把全部子公司的往来数据，按照往来项目分别汇总，然后在汇总到一个大表里（该步骤可做可不做，但为了减少后续配对的复杂度，还是汇总到一个大表里好），不需要做内外部单位的区分，这样做的理由是：数据的完整性校验会非常简单，直接链接公式跟主表核对即可，而且，不剔除外部往来数据并不会影响后续的配对和抵消过程。涉及到的往来项目有：应收账款、应付账款、其他应收款、其他应付款、预收账款、预付账款。
（2）配对：
（3）抵消：
（4）输出：

3.模型设计

根据报表模板和解决思路，新建工作簿【内部往来抵消.xlsm】，所有的工作都在这个工作簿展开，其中包括①[校验表]、②[应收账款表]、③[应付账款表]、④[其他应收账款表]、⑤[其他应付账款表]、⑥[预收账款表]、⑦[预付账款表]、⑧[往来汇总表]、⑨[往来抵消表]。

为了提高代码复用率，我做了两件事：
具体的汇总操作我写成了一个带参数的函数，满足以后单表汇总和多表汇总的不同需求；
要汇总的表根据功能不同做了标准化抽象，如下图所示具体分为三大区域：标题区域（title）、基准列区域（base）、数据区域（data）。基准列区域即不为空


4.代码：

Public iRowbase As Integer    '程序逻辑起点行，用于判断标题区域
Public iColbase As Integer      '程序逻辑起点列，用于判断数据区域最大行数,一般是项目所在列.该列必须不为空！！！
Public iRowTitle As Integer     '标题区域起始行，用于判断标题区域（数据区域）最大列数

Sub 动态汇总(ByVal p As String, Optional strName As String)

Application.ScreenUpdating = False
'On Error Resume Next

iRowbase = 4
iColbase = 3
Dim arr
Dim colMax As Integer
Dim rMax As Integer
Dim FileName As String
Dim WbName As String
Dim r As Long
Dim sht As Worksheet
Dim rng As Range
Dim r1, r2 As Integer        '数据区域的起始行r1和终止行r2
Dim rowStart As Integer    '每次目标粘贴区域起始行

ShtName = Split(strName, "-")(0)

'确定标题行宽度
iRowTitle = GetRowTitle()
colMax = ActiveSheet.Cells(iRowTitle, Columns.Count).End(xlToLeft).Column

f = Dir(p & "\*.xls*")
'遍历目标文件夹
Do While f <> ""   
    WbName = Split(f, ".")(0)
    Workbooks.Open FileName:=p & "\" & f, UpdateLinks:=0, ReadOnly:=True   
    '---------------------------------------------------------------------------------------
    '检查是否有要复制的表，如果没有则记录错误并跳到下一个工作簿，增强程序容错性
    Set sht = Workbooks(f).Sheets(ShtName)
    If Err Then Err.Clear: GoTo a
    '---------------------------------------------------------------------------------------
    '以基准列判断最大行数，首先把所有隐藏的行取消   
    With Workbooks(f).Sheets(ShtName)
        .Cells.EntireColumn.Hidden = False
        .Cells.EntireRow.Hidden = False
        If Len(.Cells(r1, iColbase)) = 0 Then  GoTo a
        r2 = .Cells(r1 - 1, iColbase).End(xlDown).Row
    End With
   
    If Not (r2 < r1) Then
        With Workbooks(f).Sheets(ShtName)
            arr = .Range(.Cells(r1, 1), .Cells(r2, colMax)).Value
        End With
        
        With ThisWorkbook.ActiveSheet        
            '判断本次粘贴起始行
            rowStart = .Cells(Rows.Count, iColbase).End(xlUp).Row + 1
            .Cells(rowStart, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        End With

    End If
a:
    Workbooks(f).Close savechanges:=False
    f = Dir
Loop

Application.ScreenUpdating = True
End Sub

Function GetRowTitle() As Integer
With ActiveSheet
    '确定标题最大列数
    Dim i As Integer
    Dim j As Integer
    Dim str As String
    For j = 2 To 3: For i = iRowbase + 1 To 8
        str = .Cells(i, j).Value
        If str Like "基准列" Or str Like "*机构*" Or str Like "*项目*" Or str Like "*单位*" Or str Like "*票*" Or str Like "*类型*" Then
            GetRowTitle = i
            Exit Function
        End If
    Next i: Next j
End With
End Function

尚未完结（待续）。。。。

夏天的风shh4695

能否贴出附件，供大家学习下？

syzlove

夏天的风shh4695 发表于 2023-11-22 12:02
能否贴出附件，供大家学习下？

刚写到汇总，后面还有配对、抵消没写完，写完会上传附件。

c3a139

谢谢分享

wanghan519

遇到过同样的问题，主要是单位名称不规范这里需要人工检查，编辑距离法匹配准确率能到80%，名称很短数据少似乎不太适合用机器学习，mark一下，学习怎么更精确的匹配不规范的名称

时光如水00

坐等更新啊

半夏知秋

wanghan519 发表于 2023-11-24 18:46
遇到过同样的问题，主要是单位名称不规范这里需要人工检查，编辑距离法匹配准确率能到80%，名称很短数据少 ...

这个是不是都要用到 正则，更复杂了，而且由于个人习惯，叫法也不同，想要实现有点困难