VBA フォルダ内の全ブック、さらに全シートの一括保護、解除（パスワードはなし）

タイトルのようにフォルダの中にある全てのブックの一括保護、解除を行いたいのですがそれぞれのブック内にシートが複数含まれています（シート数はバラバラです、パスワードはありません）。

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

似たような案件を見つけたのですが
・フォルダの中にある全てのブックの一括保護、解除（１シートのみ）
や
・全てのシートの一括保護、解除（1ブックのみ）
しか見つけられませんでした。

私自身使えそうなマクロをコピーして使うことぐらいしか出来ないのでもしよろしければご協力お願い致します。

No.3 回答者： WindFaller 回答日時： 2017/01/13 13:13

こんにちは。

時々、ここの掲示板に出て来る質問です。

'//標準モジュール
Private Const myFOLDER As String = "C:\Users\Test1\" '末尾は￥を付けること
Private Const mPW As String = "123"
Sub SheetsInAllBooksProtect()
　Dim fName As String
　Dim ws As Worksheet
　fName = Dir(myFOLDER & "*.xls?", vbNormal)
　Application.ScreenUpdating = False
　Do While fName <> ""
　　If fName <> "." And fName <> ".." Then
　　　If (GetAttr(myFOLDER & fName) And vbNormal) = vbNormal Then
　　　　On Error Resume Next
　　　　If fName <> ThisWorkbook.Name Then　 '仮に違うファイルでも、同じ名称のブックは開けない
　　　　　With Workbooks.Open(myFOLDER & fName, , , , "", "")
　　　　　　If Err.Number = 0 Then
　　　　　　　Err.Clear
　　　　　　　For Each ws In .Worksheets
　　　　　　　　 ws.Protect Password:=mPW
　　　　　　　　 ''ws.Unprotect mPW　'プロテクト解除
　　　　　　　Next
　　　　　　End If
　　　　　　.Save
　　　　　　.Close False
　　　　　End With
　　　　End If
　　　End If
　　End If
　　fName = Dir
　Loop
　Application.ScreenUpdating = True
　MsgBox "とりあえず終了しましたが、調べてみてください。", vbInformation
End Sub

No.2 回答者： tatsu99 回答日時： 2017/01/13 11:37

処理対象となるブックの拡張子は以下のどれになりますか。

①xls
②xlsx
③xlsm
それともすべてが対象ですか？

No.1 回答者： jmuiny 回答日時： 2017/01/13 08:26

一つのシートの一括保護、解除は調べてわかるとの事ですので、

複数ブックの中の複数シートの繰り返し処理だけ書きます。

Sub Sample()
Dim fpath As String, fname As String
Dim wb As Workbook
Dim shcnt As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fpath = ThisWorkbook.Path & "\"
fname = Dir(fpath & "*.xlsx", vbNormal)
Do Until fname = ""
If fname <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(fpath & fname)
For shcnt = 1 To wb.Worksheets.Count
'シート保護・解除処理
Next shcnt
End If
wb.Close SaveChanges:=True
fname = Dir()
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub