工作表不受保护

我有下面的代码，将一个工作表复制到另一个工作表，只粘贴值，但保护工作表的代码不工作？ 我在这里做错了什么？

Sub GetQuote() Range("AK548").Select Selection.Copy Range("AK549").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Dim ws As Worksheet Dim sDataOutputName As String With Application .Cursor = xlWait .StatusBar = "Saving Quote & Proposal Sheet..." .ScreenUpdating = False ' Copy specific sheets ' *SET THE SHEET NAMES TO COPY BELOW* ' Array("Sheet Name", "Another sheet name", "And Another")) ' Sheet names go inside quotes, seperated by commas On Error GoTo ErrCatcher Sheets(Array("Quote & Proposal")).Copy On Error GoTo 0 ' Paste sheets as values ' Remove External Links, Hperlinks and hard-code formulas ' Make sure A1 is selected on all sheets For Each ws In ActiveWorkbook.Worksheets ws.Cells.Copy ws.[A1].PasteSpecial Paste:=xlValues ws.Cells.Hyperlinks.Delete Application.CutCopyMode = False Cells(1, 1).Select ws.Activate Next ws Cells(1, 1).Select sDataOutputName = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Quote Questions").Range("AK545").Value & ".xlsx" ' Save it with the NewName and in the same directory as original ActiveWorkbook.SaveCopyAs sDataOutputName ActiveWorkbook.Protect Password:="12345" ActiveWorkbook.Close SaveChanges:=False .Cursor = xlDefault .StatusBar = False .ScreenUpdating = True End With Exit Sub ErrCatcher: MsgBox "Specified sheets do not exist within this workbook" End Sub 

Answer 1

您正在保护工作簿并设置密码，在closures工作簿但未保存更改的下一行代码中。

Answer 2

您的代码显示工作簿保护，而不是工作表保护。 如果要保护工作表，请使用工作表保护：

 ws.Protect Password:="12345", DrawingObjects:=True, Contents:=True, Scenarios:=True 'ADD AND REMOVE PARAMETERS AS YOU WANT THEM 

Answer 3

我把： ActiveSheet.Protect Password:="12345"上方的代码行： ActiveWorkbook.SaveCopyAs sDataOutputName ，它的工作！