Question

我将两个代码放在一起进行复制以备存档。

这将创建一个副本：

ThisWorkbook.SaveCopyAs

我重新保护了我的主文件。

如何在新文件上添加新密码？

Dim strBlockedPass As String

除了ThisWorkbook.SaveCopyAs之外，我还需要使用其他代码吗？

Option Explicit
Const strPassword = "Athens"

Sub CopyWorkBook()

    Dim ws As Worksheet
    Dim strBlockedPass As String
    Dim strDatum As String
    Dim strUser As String
    Dim FileOnly As String

    strBlockedPass = "WASD1#2#3"
    FileOnly = ThisWorkbook.Name
    strDatum = Format(Date, "dd.mmm.yyyy_")
    strUser = Environ("Username")

    'to remove old Password
    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect Password:=strPassword
    Next ws

    'To create a full copy
    ThisWorkbook.SaveCopyAs Filename:="C:\Users\kka\Desktop\" & strDatum & "_" & strUser & "_" & FileOnly

    'reprotect active WorkBook with old password, after ws.unprotect
    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect Password:=strPassword
        ws.Cells.Locked = True

    'Protection is working with cell.range defined by symbols in row.3000.
    'Each cell from that range has one symbol
    On Error Resume Next
    ws.Range("A:AA").SpecialCells(xlCellTypeBlanks).Locked = False
    On Error GoTo 0
    ws.Protect Password:=strPassword, UserInterfaceOnly:=True, 
    AllowFormattingCells:=True, AllowInsertingRows:=True

Next ws

End Sub

Answer 1

Option Explicit
Const strPassword = "Athens"

Sub CopyWorkBook()

Dim ws As Worksheet
Dim strBlockedPass As String
Dim strDatum As String
Dim strUser As String
Dim FileOnly As String
Dim NewFN As Variant

Application.DisplayAlerts = False

  strBlockedPass = "WASD1#2#3"
  FileOnly = ThisWorkbook.Name
  strDatum = Format(Date, "dd.mmm.yyyy_")
  strUser = Environ("Username")

  'to remove old Password
For Each ws In ThisWorkbook.Worksheets
ws.Unprotect Password:=strPassword
Next ws

For Each ws In ThisWorkbook.Worksheets
ws.Protect Password:=strBlockedPass
Next ws
  'To create a full copy
ActiveWorkbook.SaveAs Filename:="C:\Users\klaud\Desktop\" & strDatum & "_" & strUser & "_" & FileOnly & "_Protected" & ".xlsx", FileFormat:=xlOpenXMLWorkbook

For Each ws In ThisWorkbook.Worksheets
ws.Unprotect Password:=strBlockedPass
Next ws
'reprotect active WorkBook with old password, after ws.unprotect
For Each ws In ThisWorkbook.Worksheets


ws.Unprotect Password:=strPassword
ws.Cells.Locked = True

On Error Resume Next
ws.Range("A:AA").SpecialCells(xlCellTypeBlanks).Locked = False
On Error GoTo 0
ws.Protect Password:=strPassword, UserInterfaceOnly:=True, AllowFormattingCells:=True, AllowInsertingRows:=True

Next ws

Application.DisplayAlerts = True
ActiveWorkbook.Close SaveChanges:=False
End Sub

保护工作簿，使用密码将其复制到新目的地

1 个答案: