根据“记账凭证清单”自动生成“日记账”

kanny_a · 发表于 2021-8-13 14:17

本帖最后由 kanny_a 于 2021-8-13 14:18 编辑

求助：
请各位老师帮忙，想要根据录入好的“记账凭证清单”自动生成“日记账”和其他账。
因为不懂VB，请老师帮忙用函数实现。

感谢！

zpy2 · 发表于 2021-8-14 07:15

这种感觉函数比较难。可以搜一下生成明细账或者会计财务软件。

psxk3535 · 发表于 2021-8-14 09:29

只做了上一半的公式，看看是不是这个意思

chxw68 · 发表于 2021-8-14 09:36

Sub test()
Dim r%, i%
Dim arr, brr(), lj(1 To 2) As Double
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("日记账")
km = .Range("i1")
End With
m = 1
With Worksheets("凭证一览表")
.AutoFilterMode = False
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a3:k" & r)
ReDim brr(1 To UBound(arr), 1 To 6)
For i = 1 To UBound(arr)
If arr(i, 7) = km Then
m = m + 1
brr(m, 1) = CDate(arr(i, 1) & "-" & arr(i, 2) & "-" & arr(i, 3))
brr(m, 2) = arr(i, 5)
brr(m, 3) = arr(i, 6)
brr(m, 4) = arr(i, 10)
brr(m, 5) = arr(i, 11)
End If
Next
End With
If m = 1 Then
MsgBox "没有符合条件数据！"
Exit Sub
End If
With Worksheets("期初余额表")
.AutoFilterMode = False
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a4:e" & r)
For i = 1 To UBound(arr)
If arr(i, 1) = km Then
brr(1, 1) = #1/1/2018#
brr(1, 3) = "期初余额"
brr(1, 6) = arr(i, 4) - arr(i, 5)
Exit For
End If
Next
End With
For i = 2 To m
brr(i, 6) = brr(i - 1, 6) + brr(i, 4) - brr(i, 5)
yf = Month(brr(i, 1))
If Not d.exists(yf) Then
ReDim hj(1 To 2)
Else
hj = d(yf)
End If
hj(1) = hj(1) + brr(i, 4)
hj(2) = hj(2) + brr(i, 5)
d(yf) = hj
Next
ReDim crr(1 To m + d.Count * 2 + 100, 1 To 6)
x = 0
For i = 1 To m
x = x + 1
For j = 1 To UBound(brr, 2)
crr(x, j) = brr(i, j)
Next
If Month(brr(i, 1)) <> Month(brr(i + 1, 1)) Then
x = x + 1
crr(x, 3) = "本月合计"
crr(x, 4) = d(Month(brr(i, 1)))(1)
crr(x, 5) = d(Month(brr(i, 1)))(2)
lj(1) = lj(1) + d(Month(brr(i, 1)))(1)
lj(2) = lj(2) + d(Month(brr(i, 1)))(2)
x = x + 1
crr(x, 3) = "本年累计"
crr(x, 4) = lj(1)
crr(x, 5) = lj(2)
End If
Next
With Worksheets("日记账")
.UsedRange.Offset(4, 0).Clear
With .Range("a5").Resize(x, UBound(crr, 2))
.Value = crr
.Borders.LineStyle = xlContinuous
With .Font
.Name = "Times New Roman"
.Size = 11
End With
End With
For i = 1 To x
If crr(i, 3) = "本年累计" Then
With .Cells(i + 4, 1).Resize(1, 6)
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = -16776961
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Color = -16776961
.Weight = xlThick
End With
End With
End If
Next
End With
End Sub

复制代码

chxw68 · 发表于 2021-8-14 09:36

详见附件。

chxw68 · 发表于 2021-8-14 09:59

纠正了个小BUG。

chxw68 · 发表于 2021-8-14 10:13

换一种写法。

Sub test2()
Dim r%, i%, m%
Dim arr, brr(), hj(1 To 2, 1 To 2) As Double, zrr()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Worksheets("日记账")
km = .Range("i1")
End With
m = 1
With Worksheets("凭证一览表")
.AutoFilterMode = False
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a3:k" & r)
ReDim brr(1 To UBound(arr), 1 To 6)
For i = 1 To UBound(arr)
If arr(i, 7) = km Then
m = m + 1
brr(m, 1) = CDate(arr(i, 1) & "-" & arr(i, 2) & "-" & arr(i, 3))
brr(m, 2) = arr(i, 5)
brr(m, 3) = arr(i, 6)
brr(m, 4) = arr(i, 10)
brr(m, 5) = arr(i, 11)
End If
Next
End With
With Worksheets("期初余额表")
.AutoFilterMode = False
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a4:e" & r)
For i = 1 To UBound(arr)
If arr(i, 1) = km Then
brr(1, 1) = #1/1/2018#
brr(1, 3) = "期初余额"
brr(1, 6) = arr(i, 4) - arr(i, 5)
Exit For
End If
Next
End With
For i = 2 To m
brr(i, 6) = brr(i - 1, 6) + brr(i, 4) - brr(i, 5)
Next
k = 0
yf = 0
For i = 1 To m
If Month(brr(i, 1)) <> yf Then
k = k + 1
ReDim Preserve zrr(1 To 2, 1 To k)
zrr(1, k) = i
zrr(2, k) = i
yf = Month(brr(i, 1))
Else
If k > 0 Then
zrr(2, k) = i
End If
End If
Next
ReDim crr(1 To m + UBound(zrr, 2) * 2, 1 To 6)
x = 0
For k = 1 To UBound(zrr, 2)
hj(1, 1) = 0
hj(1, 2) = 0
For i = zrr(1, k) To zrr(2, k)
x = x + 1
For j = 1 To UBound(brr, 2)
crr(x, j) = brr(i, j)
Next
hj(1, 1) = hj(1, 1) + brr(i, 4)
hj(1, 2) = hj(1, 2) + brr(i, 5)
hj(2, 1) = hj(2, 1) + brr(i, 4)
hj(2, 2) = hj(2, 2) + brr(i, 5)
Next
x = x + 1
crr(x, 3) = "本月合计"
crr(x, 4) = hj(1, 1)
crr(x, 5) = hj(1, 2)
x = x + 1
crr(x, 3) = "本年累计"
crr(x, 4) = hj(2, 1)
crr(x, 5) = hj(2, 2)
Next
With Worksheets("日记账")
.UsedRange.Offset(4, 0).Clear
With .Range("a5").Resize(x, UBound(crr, 2))
.Value = crr
.Borders.LineStyle = xlContinuous
With .Font
.Name = "Times New Roman"
.Size = 11
End With
End With
For i = 1 To x
If crr(i, 3) = "本年累计" Then
With .Cells(i + 4, 1).Resize(1, 6)
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = -16776961
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Color = -16776961
.Weight = xlThick
End With
End With
End If
Next
End With
End Sub

复制代码

chxw68 · 发表于 2021-8-14 10:14

换一种写法，感觉思路清晰了很多。

chxw68 · 发表于 2021-8-14 11:50

又打磨了一遍。

hzruziniu · 发表于 2021-8-14 16:54

帐簿2.rar (476.87 KB, 下载次数: 27)

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

[求助] 根据“记账凭证清单”自动生成“日记账”

评分

评分

评分

评分

评分