如何通过VBA自动生成对方科目

m12y34

由于工作需要经常会接触到不同单位的序时账，需要从序时账中查找到对方科目，因此想通过VBA 自动生成对方科目。

如附件所示，A列为凭证日期、B列为凭证序号，D列为科目名称，E为借贷方向（只有借和贷两种）。A列的日期相同且B列的凭证号相同的连续多行作为一笔凭证，每笔凭证（以上提到的连续多行）中与本行E列借贷方向相反（本行如果为“借”，那么方向相反即为“贷”）的科目名称（D列）为对方科目（可能会有多个）。目标是在G列自动生成对方科目，同时用“、”，隔开不同科目。

请大神指教，谢谢~（最好能够在关键语句后注释用途，便于学习）

jsgj2023

关注进展。

m12y34

经过几天的研究，简单做出了个程序。但是仍然存在问题，希望大神能够帮忙解决。
1、运行宏命令后，从46行开始出现错误，找不出原因。
2，生成的“对方科目”中会有重复的分录出现，如何取消重复项？
以下是我编的代码，烦请各位不吝赐教~ 万分感谢~~

1. im dqhs, shs, shs1, mhs1, mhs, zhs, i, n As Long                     '当前行数、首行数、总行数定义为long型
   
2. Dim mb$
   
3. 
   
4. Public Sub jg()
   
5. 
   
6. zhs = ActiveSheet.UsedRange.Rows.Count                           '总行数定义为：工作表中已使用单元格的行数
   
7. For dqhs = 2 To zhs
   
8.     a = Cells(dqhs, "A").Value
   
9.     b = Cells(dqhs, "B").Value
   
10.     shs1 = Application.WorksheetFunction.Match(a, Range("A:A"), 0)   '返回A列中，日期与当前行日期相同的首行数
    
11.     shs = Application.WorksheetFunction.Match(b, Range(Cells(shs1, "B"), Cells(shs1, "B").End(xlDown)), 0) + shs1 - 1
    
12.                                                                      '返回B列中，凭证号与当前行凭证号相同的首行数，该行确定为该笔凭证的第一行
    
13.     mhs1 = Application.WorksheetFunction.Match(a, Range(Cells(shs, "A"), Cells(shs, "A").End(xlDown)), 1) + shs - 1
    
14.                                                                      '返回A列中，日期与当前行日期相同的末行数
    
15.     mhs = Application.WorksheetFunction.Match(b, Range(Cells(shs, "B"), Cells(mhs1, "B").End(xlDown)), 1) + shs - 1
    
16.                                                                      '返回B列中，凭证号与当前行凭证号相同的末行数，该行确定为该笔凭证的最后一行
    
17.     mb = ""                                                          '给mb首个赋值
    
18.     For i = shs To mhs
    
19.         If Cells(i, "F") <> Cells(dqhs, "F") Then
    
20.         mb = mb & "、" & Cells(i, "D").Value                         'mb循环语句：用“、”连接对方科目
    
21.         End If
    
22.     Next i
    
23. 
    
24. Cells(dqhs, "H") = mb
    
25. Next dqhs
    
26. 
    
27. End Sub
    

复制代码

jsgj2023

帮顶，你这个题我是没有一点思路。

m12y34

jsgj2023 发表于 2016-11-24 21:41
帮顶，你这个题我是没有一点思路。

非常感谢，作为初学者，知识和经验都太少，实在是不知道该怎么解决了

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("序时账")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:g" & r)
   
9.     ReDim brr(1 To UBound(arr), 1 To 1)
   
10.     For i = 1 To UBound(arr)
    
11.       If Not d.exists(arr(i, 1)) Then
    
12.         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
13.       End If
    
14.       If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
15.         Set d(arr(i, 1))(arr(i, 2)) = CreateObject("scripting.dictionary")
    
16.       End If
    
17.       If Not d(arr(i, 1))(arr(i, 2)).exists(arr(i, 6)) Then
    
18.         Set d(arr(i, 1))(arr(i, 2))(arr(i, 6)) = CreateObject("scripting.dictionary")
    
19.       End If
    
20.       d(arr(i, 1))(arr(i, 2))(arr(i, 6))(arr(i, 4)) = ""
    
21.     Next
    
22.     For i = 1 To UBound(arr)
    
23.       brr(i, 1) = Join(d(arr(i, 1))(arr(i, 2))(IIf(arr(i, 6) = "借", "贷", "借")).keys, "、")
    
24.     Next
    
25.     .Range("h2").Resize(UBound(brr), 1) = brr
    
26.   End With
    
27. End Sub
    

复制代码

chxw68

前面愣是没有看懂楼主是什么意思，今天看了楼主做的结果才看懂。

m12y34

chxw68 发表于 2016-11-24 22:02
前面愣是没有看懂楼主是什么意思，今天看了楼主做的结果才看懂。

非常感谢，因为开始时，希望不是财务专业的高手能够看明白，所以做了些解释。现在看来，可能起到反效果了。您的代码好多我还看不懂，先收好，慢慢研究。
因为是初学者，只是看了《别怕，其实EXCEL其实很简单》和网上的资料，所以我的语句会有些啰嗦或者错误的地方，如果您能指明，帮助我学习。那我真是万分感激了~ 而且我还是希望能通过自己的努力和提升解决问题，这样更有成就感~~

kszcs

楼主你好：类似从对方取得这样格式的电子数据，你的这种整理结果并不理想。我是这样整理的（见附件）。同命相连，相互磋商。
也希望能用代码到达我这个效果。但认为难度很大，没有求助。
感谢chxw68 老师给的代码，减轻了大量的工作量。

v111v111v

谢谢，太神奇了