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

meng196391 · 发表于 2023-2-23 16:11

批量生成明细账.zip (45.68 KB, 下载次数: 11) 请各位老师赐教!谢谢！

meng196391 · 发表于 2023-2-24 08:21

过次页的问题解决了！

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

chxw68 · 发表于 2023-2-24 12:43

Sub test1()
Dim r%, i%, x%
Dim arr, brr, crr(), drr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
lk = [{6,6,8.5,40,8,20,20,20}]
With Worksheets("期初表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:d" & r)
For i = 2 To UBound(arr)
ReDim brr(1 To 1, 1 To 8)
brr(1, 4) = "上年结转"
brr(1, 5) = arr(i, 2)
brr(1, 6) = arr(i, 3)
brr(1, 7) = arr(i, 4)
d1(arr(i, 1)) = brr
Next
End With
With Worksheets("凭证清单")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:i" & r)
For i = 1 To UBound(arr)
If Not d.Exists(arr(i, 5)) Then
Set d(arr(i, 5)) = CreateObject("scripting.dictionary")
End If
If Not d(arr(i, 5)).Exists(arr(i, 1)) Then
Set d(arr(i, 5))(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 5))(arr(i, 1))(i) = Empty
Next
End With
ls = 8
x = 0
For Each aa In d.Keys
ReDim nhj(1 To ls)
nhj(4) = "本年累计"
x = x + 1
s = 0
For Each bb In d(aa).Keys
s = s + d(aa)(bb).Count + 1
Next
s = s + 2
ReDim brr(1 To s, 1 To ls)
m = 1
If d1.Exists(aa) Then
crr = d1(aa)
For j = 1 To UBound(crr, 2)
brr(m, j) = crr(1, j)
Next
d1.Remove (aa)
End If
For Each bb In d(aa).Keys
ReDim yhj(1 To ls)
yhj(4) = "本月合计"
For Each cc In d(aa)(bb).Keys
m = m + 1
For j = 1 To 4
brr(m, j) = arr(cc, j)
Next
For j = 7 To 9
brr(m, j - 2) = arr(cc, j)
Next
yhj(6) = yhj(6) + arr(cc, 8)
yhj(7) = yhj(7) + arr(cc, 9)
Next
m = m + 1
For j = 1 To UBound(yhj)
brr(m, j) = yhj(j)
Next
nhj(6) = nhj(6) + yhj(6)
nhj(7) = nhj(7) + yhj(7)
Next
m = m + 1
For j = 1 To UBound(nhj)
brr(m, j) = nhj(j)
Next
brr(1, 8) = brr(1, 6) - brr(1, 7)
ye = brr(1, 8)
For i = 2 To UBound(brr)
If brr(i, 4) <> "本月合计" And brr(i, 4) <> "本年累计" Then
ye = ye + brr(i, 6) - brr(i, 7)
brr(i, 8) = ye
Else
brr(i, 8) = ye
End If
Next
On Error Resume Next
Set Ws = Worksheets(aa)
If Err Then
Set Ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
Ws.Name = aa
End If
On Error GoTo 0
With Ws
.Cells.Clear
.Range("a1:d1") = Array("年度", 2022, "科目", aa)
With .Range("a2:h2")
.Value = Array("月", "日", "凭证号", "摘要", "方向", "借方", "贷方", "期末余额")
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 10
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With .Range("a3").Resize(UBound(brr), UBound(brr, 2))
.Value = brr
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 9
End With
End With
.Rows(1).Resize(2 + UBound(brr)).RowHeight = 18
For j = 1 To UBound(lk)
.Columns(j).ColumnWidth = lk(j)
Next
With .Range("a3:c" & 2 + UBound(brr) & ",e3:e" & 2 + UBound(brr))
.HorizontalAlignment = xlCenter
End With
End With
' If x = 3 Then
' Exit For
' End If
Next
End Sub

复制代码

chxw68 · 发表于 2023-2-24 12:44

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

chxw68 · 发表于 2023-2-24 14:13

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

h2016 · 发表于 2023-2-25 00:20

多字典加数组

jjmysjg · 发表于 2023-2-26 09:33

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

这代码量真大，学习大师

hbshow · 发表于 2023-3-5 19:18

感谢分享，学习中

		自动登录	找回密码
密码			免费注册

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

评分

评分

评分

评分