将凭证内容保存为流水账

ERP

ykcbf1100 发表于 2023-4-6 17:18
日记账中已有，则提示后退出不记账。

9楼有新要求

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.         If r > 1 Then
   
9.             arr = .Range("a1:a" & r)
   
10.             For i = 2 To UBound(arr)
    
11.                 d(arr(i, 1)) = Empty
    
12.             Next
    
13.         End If
    
14.     End With
    
15.     With Worksheets("制单")
    
16.         rq = .Range("a3")
    
17.         bh = .Range("h4")
    
18.         If d.exists(bh) Then
    
19.             MsgBox "[" & bh & "]已记账!"
    
20.             Exit Sub
    
21.         End If
    
22.         arr = .Range("a6:i15")
    
23.         If Len(arr(1, 1)) = 0 Then
    
24.             MsgBox "没有要记账的内容!"
    
25.             Exit Sub
    
26.         End If
    
27.     End With
    
28.     ReDim brr(1 To UBound(arr), 1 To 7)
    
29.     m = 0
    
30.     For i = 1 To UBound(arr)
    
31.         If Len(arr(i, 1)) <> 0 Then
    
32.             m = m + 1
    
33.             brr(m, 1) = bh
    
34.             brr(m, 2) = rq
    
35.             brr(m, 3) = arr(i, 2)
    
36.             brr(m, 4) = arr(i, 1)
    
37.             brr(m, 5) = arr(i, 5)
    
38.             brr(m, 6) = arr(i, 6)
    
39.             brr(m, 7) = arr(i, 7)
    
40.         End If
    
41.     Next
    
42.     With Worksheets("日记账")
    
43.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
44.         .Cells(r + 1, 1).Resize(m, UBound(brr, 2)) = brr
    
45.     End With
    
46.             
    
47.         
    
48.    
    
49. End Sub
    

复制代码

chxw68

猜测的。。

于箱长

ERP 发表于 2023-4-22 08:39
9楼有新要求了

在楼上两位老师的代码的基础上，改改就行了吧？

清风竹-

ERP 发表于 2023-4-21 21:11
新要求：类似“过账”，即将凭证内容保存为账簿形式，同一凭证号不得重复保存（即同一张凭证只保存一次）。

请看附件。