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

'------------------------------------------------------------
' 実行用マクロ
'------------------------------------------------------------
Sub 読み取り書き込みパスワード一括設定()
    '-----------------------------
    ' 定数
    '-----------------------------
    ' 現在設定されている読み取りパスワードと書き込みパスワード（半角英数、最大15文字）
    ' パスワードが設定されていないファイルが対象の場合は""（空の文字列）
    ' パスワードの設定されているファイルが対象の場合はそのパスワードを入力
    Const OLD_READ_PSSWORD   As String = ""             ' 読み取りパスワード
    Const OLD_WRITE_PASSWORD As String = ""             ' 書き込みパスワード

    ' 新たに設定する読み取りパスワードと書き込みパスワード（半角英数、最大15文字）
    ' パスワード設定をなしにする場合は""（空の文字列）
    Const NEW_READ_PSSWORD   As String = "test"         ' 読み取りパスワード
    Const NEW_WRITE_PASSWORD As String = "test"         ' 書き込みパスワード

    '-----------------------------
    ' 処理対象フォルダパス取得
    '-----------------------------
    Dim strFolderPath As String
    strFolderPath = getFolderPath(, "フォルダを選択してください")
    
    ' フォルダ選択をキャンセルした場合は抜ける
    If strFolderPath = "" Then Exit Sub

    ' フォルダが存在しない場合は抜ける
    If Dir(strFolderPath, vbDirectory) = "" Then Exit Sub
    
    '-----------------------------
    ' パスワード設定処理
    '-----------------------------
    '《指定フォルダのExcelファイルにパスワード一括設定》
    ' ・ 引数1：対象フォルダパス
    ' ・ 引数2：現在設定されている読み取りパスワード
    ' ・ 引数3：現在設定されている書き込みパスワード
    ' ・ 引数4：新たに設定する読み取りパスワード
    ' ・ 引数5：新たに設定する書き込みパスワード
    Call setPasswordForFiles(strFolderPath, _
                             OLD_READ_PSSWORD, _
                             OLD_WRITE_PASSWORD, _
                             NEW_READ_PSSWORD, _
                             NEW_WRITE_PASSWORD)
End Sub

'------------------------------------------------------------
' 選択フォルダパス取得
'------------------------------------------------------------
'［引数］
'   FolderPath：起点となるフォルダパス（既定：なし）
'   Title     ：ダイアログボックスのタイトル（既定：参照）
'［戻り値］
'   選択したフォルダパス（選択しなければ空の文字列）
'［作成日］2023.03.19　［更新日］2023.12.20
'------------------------------------------------------------
Function getFolderPath(Optional FolderPath As String = "", _
                       Optional Title As String = "参照") As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = Title
        .InitialFileName = FolderPath
        If .Show Then getFolderPath = .SelectedItems(1)
    End With
End Function

'------------------------------------------------------------
' 指定フォルダのExcelファイルにパスワード一括設定
'------------------------------------------------------------
'［引数］
'   strFolderPath   ：対象フォルダパス
'   OldReadPassword ：現在設定されている読み取りパスワード
'   OldWritePassword：現在設定されている書き込みパスワード
'   NewReadPassword ：新たに設定する読み取りパスワード
'   NewWritePassword：新たに設定する書き込みパスワード
'［作成日］2018.01.23   ［更新日］2024.12.15
'------------------------------------------------------------
Private Sub setPasswordForFiles(ByVal strFolderPath As String, _
                                ByVal OldReadPassword As String, _
                                ByVal OldWritePassword As String, _
                                ByVal NewReadPassword As String, _
                                ByVal NewWritePassword As String)
    ' フォルダパスに区切り文字追加
    strFolderPath = strFolderPath & Application.PathSeparator
    
    ' Excelファイル検索
    Dim strFileName As String
    strFileName = Dir(strFolderPath & "*.xls?")
    
    ' 画面更新無効・アラート表示無効・イベント無効
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
        
On Error Resume Next
    Dim lngCount      As Long
    Dim lngErrorCount As Long
    Dim strResult     As String
    Do Until strFileName = ""
        With Workbooks.Open(strFolderPath & strFileName, , , , OldReadPassword, OldWritePassword)
            ' ファイルの共有確認
            If .MultiUserEditing Then
                ' 共有設定解除 ※パスワードを設定している場合は Sharingpassword = "abc" のように入力
                .UnprotectSharing Sharingpassword:=""
                .ExclusiveAccess
                .SaveAs Filename:=strFolderPath & strFileName, _
                        Password:=NewReadPassword, _
                        WriteResPassword:=NewWritePassword
                .SaveAs Filename:=strFolderPath & strFileName, _
                        AccessMode:=xlShared
            Else
                .SaveAs Filename:=strFolderPath & strFileName, _
                        Password:=NewReadPassword, _
                        WriteResPassword:=NewWritePassword
            End If
            .Close SaveChanges:=False
        End With
        If Err.Number = 0 Then
            strResult = "成功：" & strFileName
            lngCount = lngCount + 1
        Else
            Err.Clear
            strResult = "エラー：" & strFileName
            lngErrorCount = lngErrorCount + 1
        End If
        
        ' 結果をイミディエイトウィンドウに出力
        Debug.Print strResult
        
        ' 次のExcelブックを検索
        strFileName = Dir()
    Loop
On Error GoTo 0

    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    strFileName = Dir("")
    
    MsgBox "設定済みファイル数：" & lngCount & vbLf & _
           "設定エラーファイル数：" & lngErrorCount & vbLf & vbLf & _
           "読み取りパスワード：" & IIf(NewReadPassword = "", "（なし）", NewReadPassword) & vbLf & _
           "書き込みパスワード：" & IIf(NewWritePassword = "", "（なし）", NewWritePassword) & vbLf & _
           "各ファイルの結果はイミディエイトウィンドウを確認してください", _
           vbInformation, "パスワード設定処理を終了しました"
End Sub

書籍紹介

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