如图：根据日记账/序时账的日期、凭证号为一组，按借贷方向生成相反的科目，并写入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 = Timer
With ActiveSheet
arr = .[a1].CurrentRegion: start_end = Array(2, 2) '开始结束行号
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)
Else
ReDim 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 For
End If
If i = UBound(arr) Then start_end(1) = i: ReDim res(1 To x): Exit For
Next
'金额判断科目
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 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
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)
End With
Debug.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 = Timer
With ActiveSheet
arr = .[a1].CurrentRegion: start_end = Array(2, 2) '开始结束行号
Do
For i = start_end(0) To UBound(arr) 'h列为空
If Len(.Cells(i, "h")) = 0 Then start_end(0) = i: Exit For
Next
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)
Else
ReDim 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 For
End If
If i = UBound(arr) Then start_end(1) = i: ReDim res(1 To x): Exit For
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) > limit
End With
Debug.Print "用时：" & Format(Timer - tm, "0.00") '耗时
End Sub
测试结果
由于耗时较长，仅部分测试
存在问题
从特殊情况可知，多对多问题一方数据量较大时，耗时增长明显；而数据量在10以内时，即便需要组合求和耗时也很少，因此编写代码时可以考虑优先处理数据量较小的部分，跳过数据量较多的部分
扩展阅读
《excelhome-如何通过VBA自动生成对方科目》
![Linux [权限]](https://img-blog.csdnimg.cn/3d399d3cb3e94394bfc8cb8209bf7738.png)
