トップ　>　汎用コード　>　パスワードの一括設定

'----------------------------------------------------------------------------------
' 指定フォルダ内のExcelファイルに読み取り・書き込みパスワードを一括設定するマクロ
'----------------------------------------------------------------------------------
' 指定フォルダ内のExcelブックを順に開き、任意の読み取り・書き込みパスワード
'（以下、パスワード）をそれぞれ設定するマクロです。
' 定数の「旧」はExcelブックを開く場合のパスワードです。対象のExcelブックに
' パスワードが設定されていない場合は ""（空白）を設定します。
'
' パスワードが設定されているExcelブックのパスワードを解除する場合は、定数の
' 「旧」に任意のパスワードを設定し、「新」に ""（空白）を設定します。
'
'［作成日］2018.01.23　［更新日］2023.12.30
' https://excel.syogyoumujou.com/vba/set_password.html
'----------------------------------------------------------------------------------
Sub setReadWritePassword()
    '--------------------------------------------
    ' 定数
    '--------------------------------------------
    '読み取りパスワード（半角英数、最大15文字）
    Const OLD_READ_PASSWORD As String = ""          '旧
    Const NEW_READ_PASSWORD As String = "test"      '新
    
    '書き込みパスワード（半角英数、最大15文字）
    Const OLD_WRITE_PASSWORD As String = ""         '旧
    Const NEW_WRITE_PASSWORD As String = "test"     '新

    '--------------------------------------------
    ' ダイアログボックスで対象のフォルダを指定
    '--------------------------------------------
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択してください"
        If .Show = True Then
            strFolderPath = .SelectedItems(1)
        Else
            Exit Sub '「キャンセル」の場合は抜ける
        End If
    End With
    
    '--------------------------------------------
    ' フォルダの存在を確認する
    '--------------------------------------------
    If Dir(strFolderPath, vbDirectory) = "" Then
        MsgBox "フォルダが見つかりません", vbExclamation, "終了します"
        Exit Sub
    End If

    '--------------------------------
    ' フォルダ内ブックを検索
    '--------------------------------
    Dim strFileName As String
    strFolderPath = strFolderPath & Application.PathSeparator 'フォルダパスに区切り文字追加
    strFileName = Dir(strFolderPath & "*.xls?")               'フォルダからExcelブックを検索
    If strFileName = "" Then                                  'ブックのパスを取得できなければ終了
        MsgBox "指定フォルダ内にExcelブックが見つかりません", vbExclamation, "終了します"
        Exit Sub
    End If
    
    '--------------------------------
    ' 各ブックにパスワードを設定
    '--------------------------------
    Dim lngCount      As Long
    Dim lngErrorCount As Long
    Application.ScreenUpdating = False  '画面更新無効
    Application.DisplayAlerts = False   '警告メッセージ表示無効
    Application.EnableEvents = False    'イベント無効
    On Error Resume Next
    Do
        Err.Clear
        
        'ブックを開く
        With Workbooks.Open(Filename:=strFolderPath & strFileName, _
                            Password:=OLD_READ_PASSWORD, _
                            WriteResPassword:=OLD_WRITE_PASSWORD)
            '読み取り・書き込みパスワードを設定し保存
            .SaveAs Filename:=strFolderPath & strFileName, _
                    Password:=NEW_READ_PASSWORD, _
                    WriteResPassword:=NEW_WRITE_PASSWORD
            .Close
        End With
        
        If Err.Number = 0 Then
            lngCount = lngCount + 1
        Else
            'エラーの場合はファイル名をイミディエイトウィンドウに出力
            Debug.Print "エラー：" & strFileName
            lngErrorCount = lngErrorCount + 1
        End If
        
        '次のExcelブックを検索
        strFileName = Dir()
    Loop Until strFileName = "" 'ブックが見つからなければループから抜ける
    On Error GoTo 0
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    strFileName = Dir("")
    
    MsgBox "設定済みファイル数：" & lngCount & vbLf & _
           "設定エラーファイル数：" & lngErrorCount & vbLf & vbLf & _
           "読み取りパスワード：" & IIf(NEW_READ_PASSWORD = "", "（なし）", NEW_READ_PASSWORD) & vbLf & _
           "書き込みパスワード：" & IIf(NEW_WRITE_PASSWORD = "", "（なし）", NEW_WRITE_PASSWORD) & vbLf & _
           IIf(lngErrorCount = 0, "", "エラーのファイル名はイミディエイトウィンドウを確認してください"), _
           vbInformation, "パスワード設定処理を終了しました"
End Sub

書籍紹介

知りたいがすぐわかる！　やりたいがすぐできる！
「Excel VBA 逆引きで学ぶ ユーザーフォーム&コントロール」（Kindle版）
ユーザーフォームを扱えると、VBAでできることが大きく広がります！
本書では、知りたいこと、やりたいことから、逆引きで学びを深められます。
※　第1章～5章まで公開しています

'共有設定ブック対応版コード　2021/4/15　追記

'読み取り、書き込みの各conOld～とconNew～は定数
'conOldは現在ファイルに設定されているパスワード。conNewは新しく設定したいパスワード。
'パスワードの設定されていないファイルが対象の場合、conOldは""（空白）。
'既にパスワードの設定されているファイルが対象の場合はconOldにそのパスワードを入力。
'パスワードを解除する場合、conNewを""（空白）。
'読み取りパスワード（半角英数、最大15文字）
Private Const conOldRPW As String = ""
Private Const conNewRPW As String = "test"
'書き込みパスワード（半角英数、最大15文字）
Private Const conOldWPW As String = ""
Private Const conNewWPW As String = "test"

Sub Set_R_W_Password() 'メインマクロ。このマクロを実行する。
    Dim strDirPath As String, strExistDir As String
    strDirPath = Search_Directory()                 'フォルダの参照
    If Len(strDirPath) = 0 Then Exit Sub            '参照キャンセルならマクロ終了
    strExistDir = IsExistence_Directory(strDirPath) 'フォルダが存在するか確認
    If Len(strExistDir) = 0 Then Exit Sub           'フォルダがなければマクロ終了
    Call Password_Set_Module(strDirPath)            'パスワード一括設定へ
End Sub

Private Function Search_Directory() As String       'フォルダの参照
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then Search_Directory = .SelectedItems(1)
    End With
End Function

Private Function IsExistence_Directory(ByVal DirPath As String) As String
    IsExistence_Directory = Dir(DirPath, vbDirectory) 'フォルダの存在確認
End Function

Private Sub Password_Set_Module(ByVal strPath As String) 'パスワードの一括設定
    Dim strTarget As String
    With Application
        strPath = strPath & .PathSeparator
        strTarget = Dir(strPath & "*.xls?")
        .ScreenUpdating = False
        .DisplayAlerts = False
        On Error Resume Next
            Do Until strTarget = ""
                With Workbooks.Open(strPath & strTarget, , , , conOldRPW, conOldWPW)
                    If .MultiUserEditing Then '共有確認　共有パスワードを設定している場合は"1234"を書き換え
                        .UnprotectSharing 'Sharingpassword:="1234"
                        .ExclusiveAccess
                        .SaveAs Filename:=strPath & strTarget, _
                        Password:=conNewRPW, WriteResPassword:=conNewWPW
                        .SaveAs Filename:=strPath & strTarget, _
                        accessMode:=xlShared
                    Else
                        .SaveAs Filename:=strPath & strTarget, _
                        Password:=conNewRPW, WriteResPassword:=conNewWPW
                    End If
                    .Close
                End With
                strTarget = Dir()
            Loop
        On Error GoTo 0
        .DisplayAlerts = True
        .ScreenUpdating = True
        strTarget = Dir("")
    End With
End Sub