[已解决]求助如何做到点击打印后以当前日期自动保存本工作表到新的表格

qinhuan66

求助如何做到点击打印后以当前日期自动保存本工作表到新的表格（相当于右键移动或复制工作表）。谢谢

打印并保存.rar (26.88 KB, 下载次数: 49)

2014-11-1 12:24 上传

点击文件名下载附件
下面的这条代码是点击打印时自动保存到当前工作表的L列。

1. Private Sub CommandButton1_Click()
   
2. Dim i, k
   
3. i = Sheets("打印").[a4].End(xlDown).Row
   
4. k = Sheets("打印").[l65536].End(xlUp).Row + 1
   
5. Sheets("打印").Range("l" & k) = Now() & "打印居民医疗保险费用支付清单"
   
6. k = Sheets("打印").[l65536].End(xlUp).Row + 1
   
7. Sheets("打印").Range("a4:g" & i).Copy Sheets("打印").Range("i" & k)
   
8. PrintPreview
   
9. PrintOut From:=1, To:=1, Copies:=1, Collate:=True
   
10. End Sub

复制代码

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-11-1 20:17

1. Private Sub CommandButton1_Click()
   
2.     Dim i, k
   
3.     i = Sheets("打印").[a4].End(xlDown).Row
   
4.     k = Sheets("打印").[l65536].End(xlUp).Row + 1
   
5.     Sheets("打印").Range("l" & k) = Now() & "打印居民医疗保险费用支付清单"
   
6.     k = Sheets("打印").[l65536].End(xlUp).Row + 1
   
7.     Sheets("打印").Range("a4:g" & i).Copy Sheets("打印").Range("i" & k)
   
8.     PrintPreview
   
9.     PrintOut From:=1, To:=1, Copies:=1, Collate:=True
   
10.     Dim strFilename$
    
11.     Application.ScreenUpdating = False
    
12.     Application.DisplayAlerts = False
    
13.     strFilename = ThisWorkbook.Path & ""
    
14.     strFilename = strFilename & Format(Date, "yyyy-mm-dd") & Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
    
15.     ActiveSheet.Copy
    
16.     For Each obj In ActiveSheet.Shapes
    
17.         obj.Delete
    
18.     Next
    
19.     With ActiveWorkbook.VBProject.VBComponents("sheet2")
    
20.         .CodeModule.DeleteLines 1, .CodeModule.CountOfLines
    
21.     End With
    
22.     ActiveWorkbook.SaveAs Filename:=strFilename
    
23.     ActiveWorkbook.Close True
    
24.     Application.ScreenUpdating = True
    
25.     Application.DisplayAlerts = True
    
26. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

楼主是要把指定工作表复制到一个新的工作簿中么？

qinhuan66

hwc2ycy 发表于 2014-11-1 12:41
楼主是要把指定工作表复制到一个新的工作簿中么？

是的。点击打印即另保存当前工作表到新的工作表。谢谢版主

hwc2ycy

直接用worksheet.copy,然后saveas。

hwc2ycy

是直接把打印工作表另存为当前日期为名称的新工作簿嘛？

hwc2ycy

1. Private Sub CommandButton1_Click()
   
2.     Dim i, k
   
3.     i = Sheets("打印").[a4].End(xlDown).Row
   
4.     k = Sheets("打印").[l65536].End(xlUp).Row + 1
   
5.     Sheets("打印").Range("l" & k) = Now() & "打印居民医疗保险费用支付清单"
   
6.     k = Sheets("打印").[l65536].End(xlUp).Row + 1
   
7.     Sheets("打印").Range("a4:g" & i).Copy Sheets("打印").Range("i" & k)
   
8.     PrintPreview
   
9.     PrintOut From:=1, To:=1, Copies:=1, Collate:=True
   
10.     Dim strFilename$
    
11.     Application.ScreenUpdating = False
    
12.     Application.DisplayAlerts = False
    
13.     strFilename = ThisWorkbook.Path & ""
    
14.     strFilename = strFilename & Format(Date, "yyyy-mm-dd") & Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
    
15.     ActiveSheet.Copy
    
16.     ActiveWorkbook.SaveAs Filename:=strFilename
    
17.     ActiveWorkbook.Close
    
18.     Application.ScreenUpdating = True
    
19.     Application.DisplayAlerts = True
    
20. End Sub

复制代码

qinhuan66

hwc2ycy 发表于 2014-11-1 17:55

谢谢版主的帮忙。如果打印时生成的另外一个工作薄不带命令按纽和带码就更好了

hwc2ycy

可以呀。不过需要修改一个设置。

qinhuan66

hwc2ycy 发表于 2014-11-1 19:14
可以呀。不过需要修改一个设置。

谢谢版主

hwc2ycy

1. Private Sub CommandButton1_Click()
   
2.     Dim i, k
   
3.     i = Sheets("打印").[a4].End(xlDown).Row
   
4.     k = Sheets("打印").[l65536].End(xlUp).Row + 1
   
5.     Sheets("打印").Range("l" & k) = Now() & "打印居民医疗保险费用支付清单"
   
6.     k = Sheets("打印").[l65536].End(xlUp).Row + 1
   
7.     Sheets("打印").Range("a4:g" & i).Copy Sheets("打印").Range("i" & k)
   
8.     PrintPreview
   
9.     PrintOut From:=1, To:=1, Copies:=1, Collate:=True
   
10.     Dim strFilename$
    
11.     Application.ScreenUpdating = False
    
12.     Application.DisplayAlerts = False
    
13.     strFilename = ThisWorkbook.Path & ""
    
14.     strFilename = strFilename & Format(Date, "yyyy-mm-dd") & Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."))
    
15.     ActiveSheet.Copy
    
16.     For Each obj In ActiveSheet.Shapes
    
17.         obj.Delete
    
18.     Next
    
19.     With ActiveWorkbook.VBProject.VBComponents("sheet2")
    
20.         .CodeModule.DeleteLines 1, .CodeModule.CountOfLines
    
21.     End With
    
22.     ActiveWorkbook.SaveAs Filename:=strFilename
    
23.     ActiveWorkbook.Close True
    
24.     Application.ScreenUpdating = True
    
25.     Application.DisplayAlerts = True
    
26. End Sub

复制代码