如何根据原表，生成多栏帐！！

fzlhb

如题！原表是 记帐凭证 ，想根据此表生成多栏帐，先谢谢各位大神了！！

liulang0808

1. Sub 按钮2_Click()
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For j = 13 To 26
   
5.         d(Cells(5, j).Value) = j
   
6.     Next j
   
7. 
   
8.     r = Sheets("记帐凭证").Cells(Rows.Count, "g").End(3).Row
   
9.     arr = Sheets("记帐凭证").Range(Sheets("记帐凭证").[g3], Sheets("记帐凭证").Cells(r, "r"))
   
10.     str1 = [h3]
    
11.     r = 6
    
12.     For j = 2 To UBound(arr)
    
13.         If arr(j, 7) = str1 Then
    
14.             If d.exists(arr(j, 8)) Then
    
15.                 Cells(r, d(arr(j, 8))) = arr(j, 12)
    
16.                 For i = 1 To 5
    
17.                     Cells(r, i + 7) = arr(j, i)
    
18.                 Next i
    
19.                 r = r + 1
    
20.             End If
    
21.         End If
    
22.     Next j
    
23.     Application.ScreenUpdating = True
    
24. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。

grf1973

1. Sub 汇总()
   
2.     yjkm = [h3]   '一级科目
   
3.     mxkm = [m5:z5] '明细科目的类别（对应子目类别）
   
4.     Set dmxkm = CreateObject("scripting.dictionary")
   
5.     For i = 1 To UBound(mxkm, 2)  '各子目在表中的位置
   
6.         dmxkm(mxkm(1, i)) = 5 + i
   
7.     Next
   
8.     arr = Sheets("记帐凭证").Range("g4:u" & Sheets("记帐凭证").[g65536].End(3).Row)  '原始数据
   
9.     ReDim brr(1 To 1000, 1 To 19)   '最后显示的表
   
10.     For i = 1 To UBound(arr)
    
11.         If arr(i, 7) = yjkm Then
    
12.             n = n + 1
    
13.             For j = 1 To 5: brr(n, j) = arr(i, j): Next
    
14.             zm = arr(i, 8) '子目
    
15.             c = Val(dmxkm(zm))
    
16.             If c = 0 Then c = dmxkm("其他")
    
17.             brr(n, c) = arr(i, 12) - arr(i, 15) '借方-贷方
    
18.         End If
    
19.     Next
    
20.     [h6:z1000].ClearContents
    
21.     If n > 0 Then [h6].Resize(n, UBound(brr, 2)) = brr
    
22. End Sub

复制代码