読み取り・書き込みパスワードの一括設定
フォルダ内にあるExcelファイルに、読み取りパスワード、書き込みパスワードを一括で設定するマクロです。設定を変更すると、パスワードを一括で解除するような使い方も可能です。
Excelマクロ管理ツール
サンプルコード
'読み取り、書き込みの各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) .SaveAs Filename:=strPath & strTarget, _ Password:=conNewRPW, WriteResPassword:=conNewWPW .Close End With strTarget = Dir() Loop On Error GoTo 0 .DisplayAlerts = True .ScreenUpdating = True strTarget = Dir("") End With End Sub
定数を変更することで、パスワードの一括解除に対応します。
[conOldRPW]
現在ファイルに設定されている読み取りパスワード。パスワードが設定されていなければ空白。
[conNewRPW]
ファイルに新しく設定する読み取りパスワード。パスワードの設定を解除する場合は空白。
[conOldWPW]
現在ファイルに設定されている書き込みパスワード。パスワードが設定されていなければ空白。
[conNewWPW]
ファイルに新しく設定する書き込みパスワード。パスワードの設定を解除する場合は空白。
上記のマクロをそのまま実行すると、該当フォルダ内の全てのExcelファイルに、読み取りパスワード(test)、書き取りパスワード(test)が設定されます。
それらを一括で解除するには、conOldを"test"にし、conNewを""(空白)にし、再度マクロを実行します。
書籍紹介本を執筆しました

VBA好きに贈る 高速化の教科書
「あなたのマクロが激速化!! Excel VBA 高速化 ~観点と実践~」(Kindle版)
マクロの高速化と一口にいっても、ExcelやVBAの仕様や特性上のもの、システムデザインといった枠組みの考え方、プログラムのテクニックといったパートに大別できます。
それらの視点や考え方といった観点を整理しながら、実践につながるデザイン思考やテクニックに踏み込んでいます。
2021/4/15
「共有設定」のブックに対応したコードを追記します。ユーザー様から質問がありました。
共有設定ブックの場合、保存方法を変えてあります。他は同じです。
'共有設定ブック対応版コード 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