[已解决]新年度自动备份数据出错问题

hwc2ycy

1. Private Sub Workbook_Open()
   
2.     Sheet1.Activate
   
3.     If Year(Date) > Sheet4.[b2] Then
   
4.         MsgBox "新年度在d盘许可档案备份目录下自动备份上年度档案表,清空后重新开始工作！", , "提示"
   
5.         aa = InputBox("请输入继续工作密码！", "密码录入")
   
6.         ' DoEvents
   
7.         If aa = VBA.Format(VBA.Date, "YYYYMMDD") Then
   
8.             MsgBox "密码正确!欢迎在新年度使用系统!"
   
9.             Application.DisplayAlerts = False
   
10.             Application.EnableEvents = False
    
11.             Application.ScreenUpdating = False
    
12. 
    
13.             Dim TheBackUpDir As String
    
14.             Dim strFile$
    
15.             TheBackUpDir = "D:\许可档案备份"
    
16.             If Len(Dir(TheBackUpDir, vbDirectory)) = 0 Then
    
17.                 MkDir TheBackUpDir
    
18.             End If
    
19.             strFile = TheBackUpDir & "" & Year(Date) - 1 & "工业产品档案备份.xls"
    
20.             ThisWorkbook.SaveCopyAs strFile
    
21.             With GetObject(strFile)
    
22.                 MsgBox .Name
    
23.                 .Windows(1).Visible = True
    
24.                 For Each ms In .Sheets(1).Shapes
    
25.                     If ms.Type = 6 Or ms.Type = 8 Then ms.Delete
    
26.                 Next ms
    
27.                 For Each vbc In .VBProject.VBComponents
    
28.                     Select Case vbc.Type
    
29.                         Case 100
    
30.                             vbc.CodeModule.DeleteLines 1, vbc.CodeModule.CountOfLines
    
31.                         Case Else
    
32.                             .VBProject.VBComponents.Remove vbc
    
33.                     End Select
    
34.                 Next vbc
    
35.                 .Close True
    
36.             End With
    
37.             Sheet1.Range("A3:T" & Sheet1.Range("A65536").End(3).Row).ClearContents
    
38.             Sheet4.[b2] = Year(Date)
    
39.             Sheet1.Select
    
40.         Else
    
41.             MsgBox "密码错误,程序退出！"
    
42.             Application.Quit
    
43.             ' ActiveWorkbook.Close False
    
44.         End If
    
45. 
    
46.     End If
    
47.     Application.DisplayAlerts = True
    
48.     Application.EnableEvents = True
    
49.     Application.ScreenUpdating = True
    
50. End Sub

复制代码

sdwffw

谢谢老师！