フォルダ内の複数ブック・シートを一括保護/解除する

フォルダの中に複数のExcelファイル(ブック)が入っており、
それら全てのブック・シートの保護/解除を一括して行うマクロを現在使用しています。(後述)



＜現在の利用状況＞
◆フォルダの中に複数のExcelファイル(ブック)が入っている（雛形、シート構成は全て同じ）
◆全てのブックにパスワード付きでブック保護・シート保護をかけている→パスワードは共通(1111)
◆マクロ用ブックは上記の処理対象ブックとは別フォルダに入れている
（現在のVBAでは同一フォルダ内に入れた状態では作動しない）
◆マクロを実行する都度、任意のフォルダを選択する


＜改善希望＞
◆マクロ用ブックと処理対象のブックを同一フォルダに入れた状態で作動するようにしたい
（同一フォルダ内の自ブック以外のブックに対してブック・シートの保護/解除を一括処理したい）



VBA初心者なので構文をどう書き換えるかで行き詰っています。
ThisWorkbook.Path を使うというのはなんとなく分かりますが、
何パターンか試してエラーの繰り返しです…。

ご教示頂けます様お願いいたします。


-------------------------------------------------------------------------
Sub 選択フォルダ内全て保護()
Dim myFol As Object, myFile As Object, sh As Worksheet
Dim openFilePath As String
Const myPass As String = "1111"
Set myFol = CreateObject("Shell.Application").BrowseForFolder(0, "フォルダを選択してください", 0)
If myFol Is Nothing Then Exit Sub
Application.ScreenUpdating = False
openFilePath = myFol.self.Path & "\"
With CreateObject("Scripting.FileSystemObject")
For Each myFile In .GetFolder(openFilePath).Files
If .GetExtensionName(myFile.Path) = "xls" Then
With Application.Workbooks.Open(myFile.Path)
For Each sh In .Worksheets
sh.Protect Password:=myPass, DrawingObjects:=False, Contents:=True, Scenarios:=True, _
AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, _
AllowInsertingRows:=True, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Next sh
.Protect Password:=myPass, Structure:=True, Windows:=False
.Save
.Close False
End With
End If
Next myFile
End With
MsgBox "終了しました"
End Sub

-------------------------------------------------------------------------

Sub 選択フォルダ内保護全て解除()
Dim myFol As Object, myFile As Object, sh As Worksheet
Dim openFilePath As String
Const myPass As String = "1111"
Set myFol = CreateObject("Shell.Application").BrowseForFolder(0, "フォルダを選択してください", 0)
If myFol Is Nothing Then Exit Sub
Application.ScreenUpdating = False
openFilePath = myFol.self.Path & "\"
With CreateObject("Scripting.FileSystemObject")
For Each myFile In .GetFolder(openFilePath).Files
If .GetExtensionName(myFile.Path) = "xls" Then
With Application.Workbooks.Open(myFile.Path)
For Each sh In .Worksheets
sh.Unprotect Password:=myPass

Next sh
.Unprotect Password:=myPass
.Save
.Close False
End With
End If
Next myFile
End With
MsgBox "終了しました"
End Sub

-------------------------------------------------------------------------

No.1 ベストアンサー 回答者： wildcard 回答日時： 2012/08/21 17:31

こんな感じでどうでしょうか？

'-------------------------------------------------
Sub 選択フォルダ内保護全て解除()
Dim myFol As Object, myFile As Object, sh As Worksheet
Dim openFilePath As String
Const myPass As String = "1111"
'Set myFol = CreateObject("Shell.Application").BrowseForFolder(0, "フォルダを選択してください", 0)
'If myFol Is Nothing Then Exit Sub
Application.ScreenUpdating = False
openFilePath = ThisWorkbook.Path & "\" '←変更
With CreateObject("Scripting.FileSystemObject")
For Each myFile In .GetFolder(openFilePath).Files
If .GetExtensionName(myFile.Path) = "xls" And openFilePath & ThisWorkbook.Name <> myFile.Path Then '←変更
With Application.Workbooks.Open(myFile.Path)
For Each sh In .Worksheets
sh.Unprotect Password:=myPass
Next sh
.Unprotect Password:=myPass
.Save
.Close False
End With
End If
Next myFile
End With
MsgBox "終了しました"
End Sub
'-------------------------------------------------
Sub 選択フォルダ内全て保護()
Dim myFol As Object, myFile As Object, sh As Worksheet
Dim openFilePath As String
Const myPass As String = "1111"
'Set myFol = CreateObject("Shell.Application").BrowseForFolder(0, "フォルダを選択してください", 0)
'If myFol Is Nothing Then Exit Sub
Application.ScreenUpdating = False
openFilePath = ThisWorkbook.Path & "\" '←変更
With CreateObject("Scripting.FileSystemObject")
For Each myFile In .GetFolder(openFilePath).Files
If .GetExtensionName(myFile.Path) = "xls" And openFilePath & ThisWorkbook.Name <> myFile.Path Then '←変更
With Application.Workbooks.Open(myFile.Path)
For Each sh In .Worksheets
sh.Protect Password:=myPass, DrawingObjects:=False, Contents:=True, Scenarios:=True, _
AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, _
AllowInsertingRows:=True, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Next sh
.Protect Password:=myPass, Structure:=True, Windows:=False
.Save
.Close False
End With
End If
Next myFile
End With
MsgBox "終了しました"
End Sub
'-------------------------------------------------

この回答へのお礼

試してみたところ、保護/解除共に希望通りに動きました！
勉強不足を痛感しています。
本当にありがとうございました。

お礼日時：2012/08/22 09:21