フォルダ内の複数のブックに異なるパスワードをまとめて設定する。

　●ファイルごとに異なるパスワードを設定

'******************************************************************
'　Excelファイルのパスワード設定確認
'******************************************************************
Sub setBookPassword()

    'フォルダの指定
    Dim sSetDir As String
    sSetDir = "C:\VBA\PassSet\"
    
    'フォルダ内のブック全てにパスワードを設定
    Debug.Print setBookPwdInDir(sSetDir)

    MsgBox "完了"

End Sub

'******************************************************************
'　フォルダ内のブック全てにパスワードを設定
'　(パスワードはファイルごとに異なるように設定）
'------------------------------------------------------------------
'　　第１引数：指定フォルダのパス
'------------------------------------------------------------------
'　　戻り値　：実行結果
'******************************************************************
Function setBookPwdInDir(sDirPath As String) As String
    Dim sRtn As String

    'FileSystemObjectの作成
    Dim oFso As Object
    Set oFso = CreateObject("Scripting.FileSystemObject")
    
    'フォルダオブジェクトの取得
    Dim oDir As Object
    Set oDir = oFso.GetFolder(sDirPath)
                
    '表示とメッセージの制御
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'フォルダにあるファイル一覧の取得
    Dim fFile As Object
    For Each fFile In oDir.Files
        
        'Excelファイルであれば処理(一時ファイル（~$）は処理対象外)
        If (oFso.GetExtensionName(fFile.Name) Like "xls*") And _
           (Left(fFile.Name, 2) <> "~$") Then
            
            'ファイルパス取得
            Dim sFilePath As String
            sFilePath = sDirPath & fFile.Name
            
            '対象のブックを開く
            On Error Resume Next
            Dim oWb As Object
            '※既にパスワードが掛かっているファイルを見分けるために引数(Password)を指定。
            Set oWb = Workbooks.Open(sFilePath, UpdateLinks:=0, password:="")
            
            '既にパスワードが掛かっていないファイルのみ処理。
            If Err.Number = 0 Then
                'パスワード設定（8桁のランダムな文字列）
                Dim sPassword As String
                sPassword = RandomStrings(8)
                
                oWb.SaveAs fileName:=sFilePath, password:=sPassword
                oWb.Close
                
                sRtn = sRtn & fFile.Name & " にパスワード（" & sPassword & "）を設定しました。" & vbCrLf
            Else
                sRtn = sRtn & fFile.Name & " は既にパスワードが設定されています。" & vbCrLf
            End If
            On Error GoTo 0
        End If
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Set oFso = Nothing
    
    setBookPwdInDir = sRtn
    
End Function

'******************************************************************
'　ランダムな文字列（パスワード）の作成
'******************************************************************
Function RandomStrings(lLen As Long) As String
    
    
    '数字＋英字(大・小文字)
    Dim iChr As Integer
    Dim sRtn As String
    sRtn = ""
    Do Until Len(sRtn) >= lLen  'lLen=桁数
        iChr = getRndScope(48, 122)
        Select Case iChr
        Case 48 To 57, 65 To 90, 97 To 122
            sRtn = sRtn & Chr(iChr)
        End Select
    Loop
    
    RandomStrings = sRtn

End Function

'******************************************************************
'　指定した範囲の数値を乱数で作成
'------------------------------------------------------------------
'　　第１引数：乱数を発生させる範囲の最小値
'　　第２引数：乱数を発生させる範囲の最大値
'------------------------------------------------------------------
'　　戻り値　：乱数値
'******************************************************************
Function getRndScope(lMinNum As Long, lMaxNum As Long) As Integer
    
    Dim iRtn As Integer
    Randomize
    iRtn = Int((lMaxNum - lMinNum + 1) * Rnd() + lMinNum)
    getRndScope = iRtn

End Function

　■実行結果