トップ　>　汎用コード　>　全ワークシートを一括保護・保護解除

'--------------------------------------------------------------------------------
' 実行マクロ　対象ブックの全ワークシートをパスワード 1234 で保護
'--------------------------------------------------------------------------------
Sub ExampleOfUse1()
    
    '保護・保護解除設定　（True：保護　False：保護解除）
    Const C_PROTECT As Boolean = True

    '保護・保護解除パスワード
    Const C_PASSWORD As String = "1234"
    
    'アクティブブックの全ワークシートをパスワード 1234 で保護
    Dim varResult As Variant
    varResult = ProtectUnprotectAllWorksheets(ActiveWorkbook, C_PROTECT, C_PASSWORD)
    
    Dim strMessage As String
    If IsArray(varResult) Then
        '戻り値が配列の場合はエラー有
        strMessage = "次のシートでエラーが発生しました。" & vbLf & vbLf
        strMessage = strMessage & Join(varResult, vbLf)
    Else
        '戻り値が配列でない場合は全ワークシートで処理成功
        strMessage = "全てのシートでの処理に成功しました"
    End If
    
    'メッセージ表示
    MsgBox strMessage, _
           vbInformation, _
           IIf(C_PROTECT, "シートの保護", "シートの保護解除")
End Sub

'--------------------------------------------------------------------------------
' 対象ブックの全ワークシートを保護・保護解除
'--------------------------------------------------------------------------------
'［引数］
'   WB       ：対象ブック
'   Protect  ：保護・保護解除設定
'              True ：保護
'              False：保護解除
'   Password ：保護・保護解除パスワード　省略すると空白
'［戻り値］
'   Empty    ：成功
'   1次元配列：失敗　保護・保護解除エラーのシート名が格納された1次元配列
'［作成日］
'   2023/07/23
' https://excel.syogyoumujou.com/vba/protect_all_worksheets.html
'--------------------------------------------------------------------------------
Function ProtectUnprotectAllWorksheets(ByRef WB As Workbook, _
                                       ByVal Protect As Boolean, _
                                       Optional Password As String = "") As Variant
    Dim Sh            As Worksheet
    Dim varArray1d()  As Variant
    Dim lngErrorCount As Long
    
    On Error Resume Next
    
    '指定シートの全ワークシートを対象に処理実行
    For Each Sh In WB.Worksheets
        If Protect Then
            '保護
            'シートが保護されていなければシートを保護
            If Not Sh.ProtectContents Then Sh.Protect Password
        Else
            '保護解除
            'シートが保護されていたらシートの保護解除
            If Sh.ProtectContents Then Sh.Unprotect Password
            
            'エラーの場合はシート名を記録
            If Err.Number <> 0 Then
                Err.Clear
                ReDim Preserve varArray1d(lngErrorCount)
                varArray1d(lngErrorCount) = Sh.Name
                lngErrorCount = lngErrorCount + 1
            End If
        End If
    Next
    
    On Error GoTo 0
    
    'エラーがあった場合は配列を戻り値に指定
    If 0 < lngErrorCount Then ProtectUnprotectAllWorksheets = varArray1d
    
End Function

'--------------------------------------------------------------------------------
' 実行マクロ２　指定フォルダの全ブックの全ワークシートをパスワード 1234 で保護
'--------------------------------------------------------------------------------
Sub ExampleOfUse2()

    '保護・保護解除設定　（True：保護　False：保護解除）
    Const C_PROTECT As Boolean = True

    '保護・保護解除パスワード
    Const C_PASSWORD As String = "1234"

    'フォルダ選択とフォルダ内のファイルパスを取得
    Dim strFolderPath As String
    Dim varFileName   As Variant
    varFileName = GetFileNameOfOneFolder(strFolderPath, "フォルダの選択")

    'フォルダ選択で「キャンセル」を選択した場合は抜ける
    If strFolderPath = "" Then Exit Sub

    'ファイルが見つからない場合は抜ける
    If Not IsArray(varFileName) Then
        MsgBox "ファイルが見つかりません", vbInformation
        Exit Sub
    End If

    'フォルダパスにフォルダ区切り文字追加
    strFolderPath = strFolderPath & Application.PathSeparator

    Dim i          As Long
    Dim WB         As Workbook
    Dim varResult  As Variant
    Dim strSuccess As String
    Dim strError   As String

    '画面更新の停止とイベントマクロを無効に設定
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    With CreateObject("Scripting.FileSystemObject")
        For i = 0 To UBound(varFileName)
            Select Case .GetExtensionName(varFileName(i)) '拡張子取得
            Case "xlsx", "xls", "xlsm"
                'ブックを開く
                Set WB = Workbooks.Open(strFolderPath & varFileName(i))

                '対象ブックの全ワークシートをパスワード 1234 で保護
                varResult = ProtectUnprotectAllWorksheets(WB, C_PROTECT, C_PASSWORD)

                If IsArray(varResult) Then
                    'エラーの場合はブック名とシート名を記録
                    strError = strError & "ブック名：" & WB.Name & vbLf
                    strError = strError & Join$(varResult, vbLf) & vbLf
                Else
                    '成功した場合はブック名を記録
                    strSuccess = strSuccess & WB.Name & vbLf
                End If
                WB.Save
                WB.Close
            End Select
        Next
    End With

    '画面更新の再開とイベントマクロを有効に設定
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    '成功したブック名の表示
    If strSuccess <> "" Then
        MsgBox "次のブックの処理に成功しました" & vbLf & strSuccess, vbInformation
    End If
    
    'エラーが発生した場合
    If strError <> "" Then
        'エラー情報をイミディエイトウィンドウに書き出し
        Debug.Print strError

        'エラー情報のセル出力確認
        If MsgBox("処理を終了しました" & vbLf & _
                  "エラー情報をセルに書き出しますか", _
                  vbQuestion + vbYesNo) = vbYes Then
             varResult = Split(strError, vbLf)
             For i = 0 To UBound(varResult)
                Cells(i + 1, "A").Value = varResult(i)
             Next
        End If
    End If

End Sub

'--------------------------------------------------------------------------------
' 単一フォルダ内のファイル名を取得する関数
'--------------------------------------------------------------------------------
'［引数］
'   FolderPath：対象フォルダパス
'               省略すると参照ダイアログボックスでフォルダを指定
'   Title     ：ダイアログボックスのタイトル（既定：参照）
'［戻り値］
'   GetFileNameOfOneFolder：Variant型
'       ファイル名を格納した1次元配列
'       ファイルが見つからない場合はEmptyを返す
'［作成日］
'   2023/01/02
'--------------------------------------------------------------------------------
Function GetFileNameOfOneFolder(Optional FolderPath As String = "", _
                                Optional Title As String = "参照") As Variant

    'FileSystemオブジェクトの生成
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")

    'FolderPathのフォルダが存在しなければ参照ダイアログボックスでフォルダを取得
    If Not FSO.FolderExists(FolderPath) Then
        '参照ダイアログボックス
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = Title
            If .Show Then FolderPath = .SelectedItems(1) Else Exit Function
        End With
    End If

    'ファイル名取得
    Dim f              As Object
    Dim lngFilesCount  As Long    'ファイル数カウント用
    Dim varFilesName() As Variant 'ファイル名格納用配列
    With FSO.GetFolder(FolderPath)
        If 0 < .Files.Count Then
            For Each f In .Files
                ReDim Preserve varFilesName(lngFilesCount)
                varFilesName(lngFilesCount) = f.Name
                lngFilesCount = lngFilesCount + 1
            Next
            GetFileNameOfOneFolder = varFilesName
        End If
    End With
End Function

'--------------------------------------------------------------------------------
' 対象ブックの全ワークシートを保護・保護解除
'--------------------------------------------------------------------------------
'［引数］
'   WB       ：対象ブック
'   Protect  ：保護・保護解除設定
'              True ：保護
'              False：保護解除
'   Password ：保護・保護解除パスワード　省略すると空白
'［戻り値］
'   Empty    ：成功
'   1次元配列：失敗　保護・保護解除エラーのシート名が格納された1次元配列
'［作成日］
'   2023/07/23
' https://excel.syogyoumujou.com/vba/protect_all_worksheets.html
'--------------------------------------------------------------------------------
Function ProtectUnprotectAllWorksheets(ByRef WB As Workbook, _
                                       ByVal Protect As Boolean, _
                                       Optional Password As String = "") As Variant
    Dim Sh            As Worksheet
    Dim varArray1d()  As Variant
    Dim lngErrorCount As Long
    
    On Error Resume Next
    
    '指定シートの全ワークシートを対象に処理実行
    For Each Sh In WB.Worksheets
        If Protect Then
            '保護
            'シートが保護されていなければシートを保護
            If Not Sh.ProtectContents Then Sh.Protect Password
        Else
            '保護解除
            'シートが保護されていたらシートの保護解除
            If Sh.ProtectContents Then Sh.Unprotect Password
            
            'エラーの場合はシート名を記録
            If Err.Number <> 0 Then
                Err.Clear
                ReDim Preserve varArray1d(lngErrorCount)
                varArray1d(lngErrorCount) = Sh.Name
                lngErrorCount = lngErrorCount + 1
            End If
        End If
    Next
    
    On Error GoTo 0
    
    'エラーがあった場合は配列を戻り値に指定
    If 0 < lngErrorCount Then ProtectUnprotectAllWorksheets = varArray1d
    
End Function