フォルダ内のエクセルにパスワードリストに従って個別パスワードを付与するマクロ

マクロエクセルと同じフォルダにあるエクセルファイルに

リストに沿ってそれぞれ個別のパスワードを付与するマクロ

コード

Sub 個別パスワード一括設定()
    Dim FolderPath As String
    Dim wb As Workbook
    Dim response As VbMsgBoxResult
    Dim ws As Worksheet
    Dim lastrow As Long
    Dim i As Long
    Dim FilePath As String

    ' バックアップを取っているか確認
    response = MsgBox("バックアップを取りましたか？", vbYesNo + vbQuestion, "バックアップの確認")

    ' バックアップを取っていない場合は終了
    If response = vbNo Then
        MsgBox "バックアップが取られていないため、作業を終了します。", vbExclamation, "作業終了"
        Exit Sub
    End If

    ' フォルダパスを設定
    FolderPath = ThisWorkbook.Path & "\"

    ' パスワードリストを設定
    Set ws = ActiveSheet

    ' パスワードリストの最終行を取得
    lastrow = ws.Range("A1").CurrentRegion.Rows.Count

    ' アラートを消す
    Application.DisplayAlerts = False

    ' パスワードリストのExcelファイルに対して繰り返し処理を実行
    For i = 2 To lastrow
        FilePath = FolderPath & ws.Cells(i, 1) & ".xlsx"

        ' ファイルが存在するか確認
        If Dir(FilePath) <> "" Then
            Set wb = Workbooks.Open(FilePath)
            wb.SaveAs FilePath, Password:=ws.Cells(i, 2)
            wb.Close SaveChanges:=False
        Else
            MsgBox "ファイルが見つかりません: " & FilePath, vbExclamation, "エラー"
        End If
    Next i

    ' アラートの設定を戻す
    Application.DisplayAlerts = True

    MsgBox "パスワード設定完了"
End Sub

注意点

• パスワードリストをアクティブシートにして実行する
• パスワードシートのA列の２行目以降にパスワードを付与したいエクセルのファイル名を入力する
• パスワードシートのB列の２行目以降からにパスワードを付与したいエクセルのパスワードを入力する
• ファイルが見つからない場合はエラーになる
• バックアップを取ってから実行する
• マクロが入ってるエクセルと同じフォルダのエクセルが対象