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

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

数组法遍历、判断、写入

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

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

Sub 生成对方科目_一对多()'适用日期凭证号连续的日记账，一对多版；start_end(1)限制代码运行结束行数Dim arr, d, e, f, res, i&, j&, x&, m, brr, b, write_col$, s$, ss$, s1$, s2$tm = Timer: write_col = "h"    '结果写入列号start_end = Array(2, 0)  '开始结束行号With ActiveSheetarr = .[a1].CurrentRegionIf start_end(1) = 0 Then start_end(1) = UBound(arr)  '结束行号默认最后一行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 Then x = x + 1: d(x) = arr(i, 4): e(x) = arr(i, 5): f(x) = arr(i, 6)If s <> ss Or i = UBound(arr) ThenReDim Preserve d(1 To x): ReDim Preserve e(1 To x): ReDim Preserve f(1 To x)ReDim res(1 To x): Exit ForEnd IfNext'金额判断科目For t = 1 To 2  '执行2次循环，尽可能多配对len_e = Len(Join(e, "")): len_f = Len(Join(f, ""))If len_e Or len_f Then    '不为空数组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 IfNextIf len_e = 0 And Abs(WorksheetFunction.sum(f)) < (0.1 ^ 6) Thens1 = "": s2 = ""  '借方为空，贷方和为0，多正多负For tt = 1 To 2   '第1遍读取数据，第2遍写入数据For i = 1 To xIf Len(f(i)) And f(i) > 0 ThenIf tt = 1 Then s1 = s1 & "，" & d(i)If tt = 2 Then res(i) = s2: f(i) = ""ElseIf Len(f(i)) And f(i) < 0 ThenIf tt = 1 Then s2 = s2 & "，" & d(i)If tt = 2 Then res(i) = s1: f(i) = ""End IfNextNextElseIf len_f = 0 And Abs(WorksheetFunction.sum(e)) < (0.1 ^ 6) Thens1 = "": s2 = ""  '贷方为空，借方和为0，多正多负For tt = 1 To 2   '第1遍读取数据，第2遍写入数据For i = 1 To xIf Len(e(i)) And e(i) > 0 ThenIf tt = 1 Then s1 = s1 & "，" & d(i)If tt = 2 Then res(i) = s2: e(i) = ""ElseIf Len(e(i)) And e(i) < 0 ThenIf tt = 1 Then s2 = s2 & "，" & d(i)If tt = 2 Then res(i) = s1: e(i) = ""End IfNextNextEnd IfEnd IfNextFor 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) > start_end(1)End WithDebug.Print "用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub

测试结果

在15248行日记账中，生成了12858行的对方科目，用时0.59秒
可以处理科目一对一、一对多的情况，以及同方向的多对多和为0的情况（如图）

多对多问题处理

考虑到多对多问题，涉及组合求和问题，耗时会比较长，因此 start_end(1) 参数控制代码运行行数。且不修改一对多版生成结果
组合求和问题调用了combin_arr1函数，代码详见《Excel·VBA数组组合函数、组合求和》（如需使用代码需复制）

Sub 生成对方科目_多对多()'适用日期凭证号连续的日记账，多对多版；start_end(1)限制代码运行结束行数；不修改一对多版生成结果Dim arr, d, e, f, res, i&, j&, x&, m, brr, b, write_col$tm = Timer: write_col = "h"  '结果写入列号start_end = Array(2, 0)  '开始结束行号With ActiveSheetarr = .[a1].CurrentRegionIf start_end(1) = 0 Then start_end(1) = UBound(arr)  '结束行号默认最后一行hrr = .Cells(1, write_col).Resize(UBound(arr), 1)   'h列数据DoFor i = start_end(0) To UBound(arr)  'h列为空If Len(hrr(i, 1)) = 0 Then start_end(0) = i: Exit ForNextReDim d(1 To 100): ReDim e(1 To 100): ReDim f(1 To 100): ReDim res(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 + 1If Len(hrr(i, 1)) = 0 Then  'h列为空d(x) = arr(i, 4): e(x) = arr(i, 5): f(x) = arr(i, 6)Elseres(x) = "，" & hrr(i, 1)  '不修改原版生成结果End IfEnd IfIf s <> ss Or i = UBound(arr) ThenReDim Preserve d(1 To x): ReDim Preserve e(1 To x): ReDim Preserve f(1 To x)ReDim Preserve res(1 To x): Exit ForEnd IfNext'金额判断科目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) > start_end(1)End WithDebug.Print "用时：" & Format(Timer - tm, "0.00")  '耗时
End Sub

测试结果

由于耗时较长，仅部分测试

多对多组合问题

多对多非组合问题

存在问题

从特殊情况可知，多对多问题一方数据量较大时，耗时增长明显；而数据量在10以内时，即便需要组合求和耗时也很少，因此编写代码时可以考虑优先处理数据量较小的部分，跳过数据量较多的部分

扩展阅读
《excelhome-如何通过VBA自动生成对方科目》