[已解决]VBA小白求助：《单据数据》打印，相关数据自动保存到《数据库》

feiaoli

需要修改：县级预算单位项目资金支出计划申请书中的宏

求助VBA：

****把县级预算单位项目资金支出计划申请书模块中的"保存"宏更换成"领用保存"宏

参考宏模块为"道具领用登记"压缩包中的 "领用保存" 宏

  烦劳各位师傅出手，不胜感激！

请修改以下宏

1. Sub 领用保存()
   
2.     Dim r&, i&, arr, brr, d As Object
   
3.     With Worksheets("出库汇总表")
   
4.         r = .Range("h" & Rows.Count).End(xlUp).Row
   
5.         If r > 1 Then
   
6.             arr = .Range("h2:h" & r)
   
7.             Set d = CreateObject("Scripting.Dictionary")
   
8.             For i = 1 To UBound(arr): d(arr(i, 1)) = "": Next
   
9.         End If
   
10.     End With
    
11.     r = Range("b" & Rows.Count).End(xlUp).Row
    
12.     If r < 5 Then MsgBox "无数据需保存": Exit Sub
    
13.    
    
14.    
    
15.     arr = Range("b5:g" & r)
    
16.     For i = 1 To UBound(arr): arr(i, 6) = Range("d3"): Next
    
17.     ReDim brr(1 To UBound(arr), 1 To 2)
    
18.     For i = 1 To UBound(brr)
    
19.         brr(i, 1) = Range("f3")
    
20.         brr(i, 2) = Range("c3")
    
21.     Next
    
22.         
    
23.     If Not d Is Nothing Then
    
24.         If Not d.exists(Range("d3").Value) Then
    
25.             With Worksheets("出库汇总表").Range("a" & Rows.Count).End(xlUp)
    
26.                 .Offset(1).Resize(UBound(brr), 2) = brr
    
27.                 .Offset(1, 2).Resize(UBound(arr), 6) = arr
    
28.             End With
    
29.         End If
    
30.     Else
    
31.         With Worksheets("出库汇总表").Range("a" & Rows.Count).End(xlUp)
    
32.             .Offset(1).Resize(UBound(brr), 2) = brr
    
33.             .Offset(1, 2).Resize(UBound(arr), 6) = arr
    
34.         End With
    
35.     End If
    
36. End Sub

复制代码

替换以下宏

1. Sub 保存()
   
2. Sheets("县级预算单位项目资金支出计划申请书").Select
   
3. lastrow = Sheets("县级预算单位项目资金支出计划数据库").Cells(Rows.Count, "d").End(3).Row + 1
   
4. With Sheets("县级预算单位项目资金支出计划数据库")
   
5.     .Cells(lastrow, 2) = [B2].Value
   
6.     .Cells(lastrow, 3) = [E2].Value
   
7.     .Cells(lastrow, 4) = [B3].Value
   
8.     .Cells(lastrow, 5) = [D3].Value
   
9.     .Cells(lastrow, 6) = [F3].Value
   
10.     .Cells(lastrow, 7) = [B4].Value
    
11.     .Cells(lastrow, 8) = [D4].Value
    
12.     .Cells(lastrow, 9) = [F4].Value
    
13.     For n = 1 To 8
    
14.        .Cells(lastrow, n + 9) = Cells(n + 10, "m")
    
15.     Next n
    
16. End With
    
17. End Sub

复制代码

最佳答案

月排行榜 / 总排行榜

hhxq001

2021-1-23 18:23

看看行不行，删除了新建按钮，点击保存按钮自动保存并生成新空表。

县级预算单位项目资金支出计划申请书-修改0123.zip (17.69 KB, 下载次数: 40)

2021-1-23 18:22 上传

点击文件名下载附件

跳转到最佳答案楼层

hhxq001

你自己不是已经改好了吗

hhxq001

看看行不行，删除了新建按钮，点击保存按钮自动保存并生成新空表。

县级预算单位项目资金支出计划申请书-修改0123.zip (17.69 KB, 下载次数: 40)

2021-1-23 18:22 上传

点击文件名下载附件

feiaoli

hhxq001 发表于 2021-1-23 18:23
看看行不行，删除了新建按钮，点击保存按钮自动保存并生成新空表。

谢谢您！已解决！很清爽的代码？

hhxq001

feiaoli 发表于 2021-1-24 16:22
谢谢您！已解决！很清爽的代码？

不建议直接打印，有时候会因为格式的微调，或者不想打印而无法保存。
有空找一个我收藏的关于文件传阅登记的表格给你参考下。