Excel·VBA自动生成日记账的对方科目

在这里插入图片描述
如图：根据日记账/序时账的日期、凭证号为一组，按借贷方向生成相反的科目，并写入H列。可能存在一对一、一对多、多对多等情况的账目

数组法遍历、判断、写入

适用日期凭证号连续的日记账

按照判断难易程度从简单开始，先判断科目一对一的同向/反向情况；再判断科目一对多且借方和贷方数组剩余数据刚好相等的情况；最后再判断多对多的情况，由于多对多可能涉及组合求和问题，耗时会比较长，因此以下代码注释了多对多的情况，另写一个sub专门处理多对多问题。（数据匹配后，对应的数组该数据会清空，方便后续判断）

组合求和问题调用了combin_arr1函数，代码详见《Excel·VBA数组组合函数、组合求和》（如需使用代码需复制）

Sub 生成对方科目()'适用日期凭证号连续的日记账，完整版代码Dim arr, d, e, f, res, i&, j&, x&, m, brr, b, write_col$write_col = "h"    '结果写入列号tm = TimerWith ActiveSheetarr = .[a1].CurrentRegion: start_end = Array(2, 2)  '开始结束行号DoReDim d(1 To 100): ReDim e(1 To 100): ReDim f(1 To 100)s = arr(start_end(0), 1) & arr(start_end(0), 2): x = 0For i = start_end(0) To UBound(arr)ss = arr(i, 1) & arr(i, 2)If s = ss Thenx = x + 1: d(x) = arr(i, 4): e(x) = arr(i, 5): f(x) = arr(i, 6)ElseReDim Preserve d(1 To x): ReDim Preserve e(1 To x): ReDim Preserve f(1 To x)start_end(1) = i - 1: ReDim res(1 To x): Exit ForEnd IfIf i = UBound(arr) Then start_end(1) = i: ReDim res(1 To x): Exit ForNext'金额判断科目For t = 1 To 2  '执行2次循环，尽可能多配对For i = 1 To x    '一对一If Len(e(i)) Then    '一借一贷m = Application.Match(e(i), f, 0)If TypeName(m) <> "Error" Then res(i) = res(i) & "，" & d(m): res(m) = res(m) & "，" & d(i): e(i) = "": f(m) = ""End IfIf Len(f(i)) Then    '一借一贷m = Application.Match(f(i), e, 0)If TypeName(m) <> "Error" Then res(i) = res(i) & "，" & d(m): res(m) = res(m) & "，" & d(i): f(i) = "": e(m) = ""End IfIf Len(e(i)) Then    '同方向一正一负m = Application.Match(-e(i), e, 0)If TypeName(m) <> "Error" Then res(i) = res(i) & "，" & d(m): res(m) = res(m) & "，" & d(i): e(i) = "": e(m) = ""End IfIf Len(f(i)) Then    '同方向一正一负m = Application.Match(-f(i), f, 0)If TypeName(m) <> "Error" Then res(i) = res(i) & "，" & d(m): res(m) = res(m) & "，" & d(i): f(i) = "": f(m) = ""End IfIf Len(e(i)) Then    '一借多贷，剩余金额相等；计算精度问题ts = WorksheetFunction.sum(f)If e(i) = ts Or Abs(Round(e(i) - ts, 6)) < (0.1 ^ 6) ThenFor j = 1 To xIf Len(f(j)) Then res(i) = res(i) & "，" & d(j): res(j) = res(j) & "，" & d(i): e(i) = "": f(j) = ""NextEnd IfEnd IfIf Len(f(i)) Then    '多借一贷，剩余金额相等ts = WorksheetFunction.sum(e)If f(i) = ts Or Abs(Round(f(i) - ts, 6)) < (0.1 ^ 6) ThenFor j = 1 To xIf Len(e(j)) Then res(i) = res(i) & "，" & d(j): res(j) = res(j) & "，" & d(i): f(i) = "": e(j) = ""NextEnd IfEnd IfNextNext
'            For i = 1 To x  '一借一贷，一对多
'                If x > 20 Then Debug.Print "数据太多，求和速度慢": Exit For
'                If Len(e(i)) Then    '一借一贷，一对多
'                    For j = x - 1 To 2 Step -1
'                        brr = combin_arr1(f, j)  '调用函数返回组合，一维嵌套数组
'                        For Each b In brr
'                            temp_sum = WorksheetFunction.sum(b)
'                            If temp_sum = e(i) Then
'                                For Each bb In b
'                                    If Len(bb) Then
'                                        m = Application.Match(bb, f, 0)
'                                        res(i) = res(i) & "，" & d(m): res(m) = res(m) & "，" & d(i): f(m) = ""
'                                    End If
'                                Next
'                                e(i) = "": Exit For
'                            End If
'                        Next
'                        If e(i) = "" Then Exit For
'                    Next
'                End If
'                If Len(f(i)) Then    '一借一贷，一对多
'                    For j = x - 1 To 2 Step -1
'                        brr = combin_arr1(e, j)
'                        For Each b In brr
'                            temp_sum = WorksheetFunction.sum(b)
'                            If temp_sum = f(i) Then
'                                For Each bb In b
'                                    If Len(bb) Then
'                                        m = Application.Match(bb, e, 0)
'                                        res(i) = res(i) & "，" & d(m): res(m) = res(m) & "，" & d(i): e(m) = ""
'                                    End If
'                                Next
'                                f(i) = "": Exit For
'                            End If
'                        Next
'                        If f(i) = "" Then Exit For
'                    Next
'                End If
'            Next
'            If Len(Join(e, ",")) >= x Or Len(Join(f, ",")) >= x Then
'                For i = 1 To x    '多借多贷，无法组合求和
'                    If Len(e(i)) Then
'                        For j = 1 To x
'                            If Len(f(j)) Then res(i) = res(i) & "，" & d(j): res(j) = res(j) & "，" & d(i)
'                        Next
'                    End If
'                Next
'            End IfFor i = 1 To x    '清除开头的"，"If Len(res(i)) Then res(i) = Mid(res(i), 2)Next.Cells(start_end(0), write_col).Resize(x, 1) = WorksheetFunction.Transpose(res)start_end(0) = start_end(0) + xLoop Until start_end(0) > UBound(arr)End WithDebug.Print "用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub

测试结果

在15248行日记账中，生成了12787行的对方科目，用时0.55秒

多对多问题处理

考虑到多对多问题，涉及组合求和问题，耗时会比较长，因此添加limit参数控制代码运行行数

Sub 生成对方科目_多对多()'适用日期凭证号连续的日记账，多对多Dim arr, d, e, f, res, i&, j&, x&, m, brr, b, write_col$, limit&limit = 3111: write_col = "h"   '代码运行结束行数限制，结果写入列号tm = TimerWith ActiveSheetarr = .[a1].CurrentRegion: start_end = Array(2, 2)  '开始结束行号DoFor i = start_end(0) To UBound(arr)  'h列为空If Len(.Cells(i, "h")) = 0 Then start_end(0) = i: Exit ForNextReDim d(1 To 100): ReDim e(1 To 100): ReDim f(1 To 100)s = arr(start_end(0), 1) & arr(start_end(0), 2): x = 0For i = start_end(0) To UBound(arr)ss = arr(i, 1) & arr(i, 2)If s = ss Thenx = x + 1: d(x) = arr(i, 4): e(x) = arr(i, 5): f(x) = arr(i, 6)ElseReDim Preserve d(1 To x): ReDim Preserve e(1 To x): ReDim Preserve f(1 To x)start_end(1) = i - 1: ReDim res(1 To x): Exit ForEnd IfIf i = UBound(arr) Then start_end(1) = i: ReDim res(1 To x): Exit ForNext'金额判断科目For i = 1 To x  '一借一贷，一对多If x > 20 Then Debug.Print "数据太多，求和速度慢": Exit ForIf Len(e(i)) Then    '一借一贷，一对多For j = x - 1 To 2 Step -1brr = combin_arr1(f, j)  '调用函数返回组合，一维嵌套数组For Each b In brrtemp_sum = WorksheetFunction.sum(b)If temp_sum = e(i) ThenFor Each bb In bIf Len(bb) Thenm = Application.Match(bb, f, 0)res(i) = res(i) & "，" & d(m): res(m) = res(m) & "，" & d(i): f(m) = ""End IfNexte(i) = "": Exit ForEnd IfNextIf e(i) = "" Then Exit ForNextEnd IfIf Len(f(i)) Then    '一借一贷，一对多For j = x - 1 To 2 Step -1brr = combin_arr1(e, j)For Each b In brrtemp_sum = WorksheetFunction.sum(b)If temp_sum = f(i) ThenFor Each bb In bIf Len(bb) Thenm = Application.Match(bb, e, 0)res(i) = res(i) & "，" & d(m): res(m) = res(m) & "，" & d(i): e(m) = ""End IfNextf(i) = "": Exit ForEnd IfNextIf f(i) = "" Then Exit ForNextEnd IfNextIf Len(Join(e, ",")) >= x Or Len(Join(f, ",")) >= x ThenFor i = 1 To x    '多借多贷，无法组合求和If Len(e(i)) ThenFor j = 1 To xIf Len(f(j)) Then res(i) = res(i) & "，" & d(j): res(j) = res(j) & "，" & d(i)NextEnd IfNextEnd IfFor i = 1 To x    '清除开头的"，"If Len(res(i)) Then res(i) = Mid(res(i), 2)Next.Cells(start_end(0), write_col).Resize(x, 1) = WorksheetFunction.Transpose(res)start_end(0) = start_end(0) + xLoop Until start_end(0) > UBound(arr) Or start_end(0) > limitEnd WithDebug.Print "用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub