VBAでシートの保護

質問

初めまして。
私はWindowsXP、Excel2003のVBAでシートの保護、またそれの解除のコードを組んだのですが、以下のコードでは「○○○と言う名前で保存します。よろしければこのままOKをクリックしてください」の箇所でキャンセルを選択した時に、シートの保護を行いたいのですが、どのようなコードにすればよいてのでしょうか？
例）
　 Dim FileName As String
Dim FileExt As String
Dim BkName1 As String
Dim BkName2 As String
Dim BkName3 As String
Dim OldWkbook As Workbook
Dim NewWkbook As Workbook
Const StName1 As String = "適材適所グラフ"
Const StName2 As String = "適材適所回答"
Const StName3 As String = "適性検査III回答"
Const StName4 As String = "適性検査IIIグラフ"

'シートの保護を解除
Worksheets("適性検査III回答").Unprotect
Worksheets("適材適所回答").Unprotect

Application.DisplayAlerts = False
Set OldWkbook = ActiveWorkbook
'
'ファイル名を取得
BkName1 = OldWkbook.Sheets(StName3).Range("L1").Value
BkName2 = OldWkbook.Sheets(StName3).Range("L2").Value
BkName3 = OldWkbook.Sheets(StName3).Range("L3").Value

FileName = BkName1 & Format(".") & BkName2 & Format(".") & BkName3 & ".xls"
'
FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)
If FileName = "" Then
Exit Sub
Else
If Right(FileName, 4) <> ".xls" Then
MsgBox "ファイル名が異常です。"
Exit Sub
End If
End If

OldWkbook.Sheets(Array(StName1, StName2, StName3, StName4)).Copy

Set NewWkbook = ActiveWorkbook

'ボタンを削除
For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1
If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除
NewWkbook.Sheets(1).Shapes(wIx).Delete
End If
Next

NewWkbook.Sheets(1).Name = StName1

'コピー先シートの保護
Sheets(1).Protect
Sheets(2).Protect
Sheets(3).Protect
Sheets(4).Protect

FileName = "C:\採点結果\" & FileName

If Dir(FileName) <> "" Then
'##ファイルが既に存在する
If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then

NewWkbook.Close savechanges:=False

'##保存せずに終了
Exit Sub
'##指定ファイル置き換え保存
End If
NewWkbook.SaveAs FileName:=FileName
Else
'##ファイルを新規保存
NewWkbook.SaveAs FileName:=FileName
End If

NewWkbook.Close savechanges:=False
Application.DisplayAlerts = True

'シートの保護
Worksheets("適性検査III回答").Protect
Worksheets("適材適所回答").Protect

End Sub

回答No.4

pkh4989 · ベストアンサー

Const StName1 As String = "適材適所グラフ"
Const StName2 As String = "適材適所回答"
Const StName3 As String = "適性検査III回答"
Const StName4 As String = "適性検査IIIグラフ"

'シートの保護を解除
Worksheets("適性検査III回答").Unprotect　　　 '←これを削除しましたか？
Worksheets("適材適所回答").Unprotect　　　　　'←これを削除しましたか？

Application.DisplayAlerts = False
Set OldWkbook = ActiveWorkbook

一番上の保護を解除を削除しても変わりがないなら、手動でシートを保護してブックを保存してから
実行してください。
どうしてもVBAで保護したいなら、以下のように追加してください。

FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName)
If FileName = "" Then
　　Worksheets("適性検査III回答").protect　　　 '←これを追加
　　Worksheets("適材適所回答").protect　　　　　'←これを追加
　　Exit Sub
Else
　　If Right(FileName, 4) <> ".xls" Then
　　　　MsgBox "ファイル名が異常です。"
　　　　Worksheets("適性検査III回答").protect　　　 '←これを追加
　　　　Worksheets("適材適所回答").protect　　　　　'←これを追加
　　　　Exit Sub
　　End If
End If

お礼

できました！！
ありがとうございます。