一括パスワード解除

Option Explicit '読み取り、書き込みの各conOld～とconNew～は定数 'conOldは現在ファイルに設定されているパスワード。conNewは新しく設定したいパスワード。 'パスワードの設定されていないファイルが対象の場合、conOldは""（空白）。 '既にパスワードの設定されているファイルが対象の場合はconOldにそのパスワードを入力。 'パスワードを解除する場合、conNewを""（空白）。 '読み取りパスワード（半角英数、最大15文字） Private Const conOldRPW As String = "0001" Private Const conNewRPW As String = "" '書き込みパスワード（半角英数、最大15文字） Private Const conOldWPW As String = "0001" Private Const conNewWPW As String = "" 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) 'パスワード一括設定へ MsgBox "OK" 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 結合解除 .Save .Close End With strTarget = Dir() Loop On Error GoTo 0 .DisplayAlerts = True .ScreenUpdating = True strTarget = Dir("") End With End Sub Sub 結合解除() ' Worksheets.Select Columns("B:E").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With 文字 Range("F6").Select ActiveCell.FormulaR1C1 = "=DATE(R[-2]C,R[-2]C[3],R[-2]C[5])" コピー名前 End Sub '------------------------------------------------------------------------- Sub 文字() Cells.Select With Selection.Font .Name = "ＭＳ Ｐゴシック" .Size = 11 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .TintAndShade = 0 .ThemeFont = xlThemeFontNone End With Range("B2").Select End Sub Sub コピー名前() Range("B8").Select Selection.AutoFill Destination:=Range("B8:B22") Range("B8:B22").Select Range("B23").Select Selection.AutoFill Destination:=Range("B23:B37") Range("B23:B37").Select Range("B38").Select Selection.AutoFill Destination:=Range("B38:B52") Range("B38:B52").Select Range("B53").Select Selection.AutoFill Destination:=Range("B53:B67") Range("B53:B67").Select Range("B68").Select Selection.AutoFill Destination:=Range("B68:B82") Range("B68:B82").Select Range("B83").Select Selection.AutoFill Destination:=Range("B83:B97") Range("B83:B97").Select Range("B98").Select Selection.AutoFill Destination:=Range("B98:B112") Range("B98:B112").Select Range("B113").Select Selection.AutoFill Destination:=Range("B113:B127") Range("B113:B127").Select Range("B128").Select Selection.AutoFill Destination:=Range("B128:B142") Range("B128:B142").Select Range("B143").Select Selection.AutoFill Destination:=Range("B143:B157") Range("B143:B157").Select Range("B2").Select End Sub