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 ActiveSheet
arr = .[a1].CurrentRegion
If start_end(1) = 0 Then start_end(1) = UBound(arr) '结束行号默认最后一行
Do
ReDim 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 = 0
For 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) Then
ReDim Preserve d(1 To x): ReDim Preserve e(1 To x): ReDim Preserve f(1 To x)
ReDim res(1 To x): Exit For
End If
Next
'金额判断科目
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 If
If 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 If
If 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 If
If 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 If
If Len(e(i)) Then '一借多贷，剩余金额相等；计算精度问题
ts = WorksheetFunction.sum(f)
If e(i) = ts Or Abs(Round(e(i) - ts, 6)) < (0.1 ^ 6) Then
For j = 1 To x
If Len(f(j)) Then res(i) = res(i) & "，" & d(j): res(j) = res(j) & "，" & d(i): e(i) = "": f(j) = ""
Next
End If
End If
If Len(f(i)) Then '多借一贷，剩余金额相等
ts = WorksheetFunction.sum(e)
If f(i) = ts Or Abs(Round(f(i) - ts, 6)) < (0.1 ^ 6) Then
For j = 1 To x
If Len(e(j)) Then res(i) = res(i) & "，" & d(j): res(j) = res(j) & "，" & d(i): f(i) = "": e(j) = ""
Next
End If
End If
Next
If len_e = 0 And Abs(WorksheetFunction.sum(f)) < (0.1 ^ 6) Then
s1 = "": s2 = "" '借方为空，贷方和为0，多正多负
For tt = 1 To 2 '第1遍读取数据，第2遍写入数据
For i = 1 To x
If Len(f(i)) And f(i) > 0 Then
If tt = 1 Then s1 = s1 & "，" & d(i)
If tt = 2 Then res(i) = s2: f(i) = ""
ElseIf Len(f(i)) And f(i) < 0 Then
If tt = 1 Then s2 = s2 & "，" & d(i)
If tt = 2 Then res(i) = s1: f(i) = ""
End If
Next
Next
ElseIf len_f = 0 And Abs(WorksheetFunction.sum(e)) < (0.1 ^ 6) Then
s1 = "": s2 = "" '贷方为空，借方和为0，多正多负
For tt = 1 To 2 '第1遍读取数据，第2遍写入数据
For i = 1 To x
If Len(e(i)) And e(i) > 0 Then
If tt = 1 Then s1 = s1 & "，" & d(i)
If tt = 2 Then res(i) = s2: e(i) = ""
ElseIf Len(e(i)) And e(i) < 0 Then
If tt = 1 Then s2 = s2 & "，" & d(i)
If tt = 2 Then res(i) = s1: e(i) = ""
End If
Next
Next
End If
End If
Next
For 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) + x
Loop Until start_end(0) > UBound(arr) Or start_end(0) > start_end(1)
End With
Debug.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 ActiveSheet
arr = .[a1].CurrentRegion
If start_end(1) = 0 Then start_end(1) = UBound(arr) '结束行号默认最后一行
hrr = .Cells(1, write_col).Resize(UBound(arr), 1) 'h列数据
Do
For i = start_end(0) To UBound(arr) 'h列为空
If Len(hrr(i, 1)) = 0 Then start_end(0) = i: Exit For
Next
ReDim 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 = 0
For i = start_end(0) To UBound(arr)
ss = arr(i, 1) & arr(i, 2)
If s = ss Then
x = x + 1
If Len(hrr(i, 1)) = 0 Then 'h列为空
d(x) = arr(i, 4): e(x) = arr(i, 5): f(x) = arr(i, 6)
Else
res(x) = "，" & hrr(i, 1) '不修改原版生成结果
End If
End If
If s <> ss Or i = UBound(arr) Then
ReDim Preserve d(1 To x): ReDim Preserve e(1 To x): ReDim Preserve f(1 To x)
ReDim Preserve res(1 To x): Exit For
End If
Next
'金额判断科目
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 If
For 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) + x
Loop Until start_end(0) > UBound(arr) Or start_end(0) > start_end(1)
End With
Debug.Print "用时：" & Format(Timer - tm, "0.00") '耗时
End Sub
测试结果
由于耗时较长，仅部分测试
多对多组合问题
多对多非组合问题
存在问题
从特殊情况可知，多对多问题一方数据量较大时，耗时增长明显；而数据量在10以内时，即便需要组合求和耗时也很少，因此编写代码时可以考虑优先处理数据量较小的部分，跳过数据量较多的部分
扩展阅读
《excelhome-如何通过VBA自动生成对方科目》