批量生成明细账后有几个问题，请各位老师！帮忙看一下！

meng196391

批量生成明细账.zip (45.68 KB, 下载次数: 11)

2023-2-23 16:09 上传

点击文件名下载附件

    请各位老师赐教!谢谢！

meng196391

过次页的问题解决了！ 批量生成明细账.zip (46.11 KB, 下载次数: 15)

2023-2-24 08:20 上传

点击文件名下载附件

chxw68

1. Sub test1()
   
2.     Dim r%, i%, x%
   
3.     Dim arr, brr, crr(), drr
   
4.     Dim d As Object
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     Set d2 = CreateObject("scripting.dictionary")
   
10.     lk = [{6,6,8.5,40,8,20,20,20}]
    
11.     With Worksheets("期初表")
    
12.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.         arr = .Range("a2:d" & r)
    
14.         For i = 2 To UBound(arr)
    
15.             ReDim brr(1 To 1, 1 To 8)
    
16.             brr(1, 4) = "上年结转"
    
17.             brr(1, 5) = arr(i, 2)
    
18.             brr(1, 6) = arr(i, 3)
    
19.             brr(1, 7) = arr(i, 4)
    
20.             d1(arr(i, 1)) = brr
    
21.         Next
    
22.     End With
    
23. 
    
24. 
    
25.     With Worksheets("凭证清单")
    
26.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
27.         arr = .Range("a2:i" & r)
    
28.         For i = 1 To UBound(arr)
    
29.             If Not d.Exists(arr(i, 5)) Then
    
30.                 Set d(arr(i, 5)) = CreateObject("scripting.dictionary")
    
31.             End If
    
32.             If Not d(arr(i, 5)).Exists(arr(i, 1)) Then
    
33.                 Set d(arr(i, 5))(arr(i, 1)) = CreateObject("scripting.dictionary")
    
34.             End If
    
35.             d(arr(i, 5))(arr(i, 1))(i) = Empty
    
36.         Next
    
37.     End With
    
38.     ls = 8
    
39.     x = 0
    
40.     For Each aa In d.Keys
    
41.         ReDim nhj(1 To ls)
    
42.         nhj(4) = "本年累计"
    
43.         x = x + 1
    
44.         s = 0
    
45.         For Each bb In d(aa).Keys
    
46.             s = s + d(aa)(bb).Count + 1
    
47.         Next
    
48.         s = s + 2
    
49.         ReDim brr(1 To s, 1 To ls)
    
50.         m = 1
    
51.         If d1.Exists(aa) Then
    
52.             crr = d1(aa)
    
53.             For j = 1 To UBound(crr, 2)
    
54.                 brr(m, j) = crr(1, j)
    
55.             Next
    
56.             d1.Remove (aa)
    
57.         End If
    
58.         For Each bb In d(aa).Keys
    
59.             ReDim yhj(1 To ls)
    
60.             yhj(4) = "本月合计"
    
61.             For Each cc In d(aa)(bb).Keys
    
62.                 m = m + 1
    
63.                 For j = 1 To 4
    
64.                     brr(m, j) = arr(cc, j)
    
65.                 Next
    
66.                 For j = 7 To 9
    
67.                     brr(m, j - 2) = arr(cc, j)
    
68.                 Next
    
69.                 yhj(6) = yhj(6) + arr(cc, 8)
    
70.                 yhj(7) = yhj(7) + arr(cc, 9)
    
71.             Next
    
72.             m = m + 1
    
73.             For j = 1 To UBound(yhj)
    
74.                 brr(m, j) = yhj(j)
    
75.             Next
    
76.             nhj(6) = nhj(6) + yhj(6)
    
77.             nhj(7) = nhj(7) + yhj(7)
    
78.         Next
    
79.         m = m + 1
    
80.         For j = 1 To UBound(nhj)
    
81.             brr(m, j) = nhj(j)
    
82.         Next
    
83.         brr(1, 8) = brr(1, 6) - brr(1, 7)
    
84.         ye = brr(1, 8)
    
85.         For i = 2 To UBound(brr)
    
86.             If brr(i, 4) <> "本月合计" And brr(i, 4) <> "本年累计" Then
    
87.                 ye = ye + brr(i, 6) - brr(i, 7)
    
88.                 brr(i, 8) = ye
    
89.             Else
    
90.                 brr(i, 8) = ye
    
91.             End If
    
92.         Next
    
93.                
    
94.         On Error Resume Next
    
95.         Set Ws = Worksheets(aa)
    
96.         If Err Then
    
97.             Set Ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
98.             Ws.Name = aa
    
99.         End If
    
100.         On Error GoTo 0
     
101.         With Ws
     
102.             .Cells.Clear
     
103.             .Range("a1:d1") = Array("年度", 2022, "科目", aa)
     
104.             With .Range("a2:h2")
     
105.                 .Value = Array("月", "日", "凭证号", "摘要", "方向", "借方", "贷方", "期末余额")
     
106.                 .Borders.LineStyle = xlContinuous
     
107.                 With .Font
     
108.                     .Name = "微软雅黑"
     
109.                     .Size = 10
     
110.                 End With
     
111.                 .HorizontalAlignment = xlCenter
     
112.                 .VerticalAlignment = xlCenter
     
113.             End With
     
114.             With .Range("a3").Resize(UBound(brr), UBound(brr, 2))
     
115.                 .Value = brr
     
116.                 .Borders.LineStyle = xlContinuous
     
117.                 With .Font
     
118.                     .Name = "微软雅黑"
     
119.                     .Size = 9
     
120.                 End With
     
121.             End With
     
122.             .Rows(1).Resize(2 + UBound(brr)).RowHeight = 18
     
123.             For j = 1 To UBound(lk)
     
124.                 .Columns(j).ColumnWidth = lk(j)
     
125.             Next
     
126.             With .Range("a3:c" & 2 + UBound(brr) & ",e3:e" & 2 + UBound(brr))
     
127.               .HorizontalAlignment = xlCenter
     
128.             End With
     
129.         End With
     
130. '        If x = 3 Then
     
131. '            Exit For
     
132. '        End If
     
133.             
     
134.     Next
     
135. 
     
136. End Sub
     
137. 
     
138. 
     

复制代码

chxw68

昨天刚写过一个类似的，简单修改就能用，过次页和承前页有空了再完善。

chxw68

又修改了一下。过次页和承前页要根据纸张打印方向、页边距等来设定。

h2016

多字典加数组

jjmysjg

chxw68 发表于 2023-2-24 14:13
又修改了一下。过次页和承前页要根据纸张打印方向、页边距等来设定。

这代码量真大，学习大师

hbshow

感谢分享，学习中