Change password on multiple excel files in folders and subfolders

Anonymous
2019-11-10T17:11:46+00:00

Hi,

I have over 300 files in subfolders of which some are .xls .xlsx and .xlsm. They are all set with the same password, and I would like to change it once in a while.

I used the following script to set the password, but when I want to change the password the files prompt me for the original password. I don't know how to add an option for  when a spreadsheet is already password protected?

Public Sub addPassword()

  Dim FSO As Object

  Dim folder As Object, subfolder As Object

  Dim wb As Object

  Set FSO = CreateObject("Scripting.FileSystemObject")

  'update the path where the files are saved below

  folderPath = "C:\Users\Test"

  Set folder = FSO.GetFolder(folderPath)

     With Application

    .DisplayAlerts = False

    .ScreenUpdating = False

    .EnableEvents = False

    .AskToUpdateLinks = False

  End With

  For Each wb In folder.Files

    'the different formats below are specificied with "xls", "xlsx" and "xlsm"

    If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then

      Set masterWB = Workbooks.Open(wb)

      'update "yourpassword" to the password you would like to use, below

      ActiveWorkbook.SaveAs Filename:=Application.ActiveWorkbook.FullName, Password:="Standard Password"

      ActiveWorkbook.Close True

    End If

  Next

  For Each subfolder In folder.SubFolders

  For Each wb In subfolder.Files

      If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then

        Set masterWB = Workbooks.Open(wb)

        'update "yourpassword" to the password you would like to use, below

        ActiveWorkbook.SaveAs Filename:=Application.ActiveWorkbook.FullName, Password:="Standard Password"

        ActiveWorkbook.Close True

      End If

    Next

  Next

  With Application

    .DisplayAlerts = True

    .ScreenUpdating = True

    .EnableEvents = True

    .AskToUpdateLinks = True

  End With

End Sub

Microsoft 365 and Office | Excel | For home | Windows

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments
Answer accepted by question author
Andreas Killer 144.1K Reputation points Volunteer Moderator
2019-11-10T18:23:08+00:00

Download this file:

https://www.dropbox.com/s/700hbz18bsc7nu2/FileSearch.cls?dl=1

Make a new Excel file

Open the VBA editor

Import the downloaded file

Create a new regular module

Paste in the code below

Customize the constants at the top of the sub

Run it

After the macro is finished all files that causes an error are listed in the sheet.

Andreas.

Sub Test()

  'Setup the passwords here:

  Const OldPassword = "old"

  Const NewPassword = "new"

  'Path to the folder that contains the files

  Const FilePath = "C:\Users\Test"

  'No need to change anything below this line

  Dim FS As New FileSearch

  Dim Wb As Workbook

  Dim FName

  Dim Dest As Range

  With FS

    'Setup the search arguments

    .LookIn = FilePath

    .FileName = "*.xls*"

    .SearchSubFolders = True

    'Go

    .Execute

    'Prepare

    With Application

      .ScreenUpdating = False

      .DisplayAlerts = False

      .EnableEvents = False

      .Calculation = xlCalculationManual

    End With

    'First cell for errors

    Set Dest = Range("A1:B1")

    Dest = Array("Error", "Filename")

    Set Dest = Dest.Offset(1)

    On Error GoTo Errorhandler

    For Each FName In .FoundFiles

      'Skip ourself

      If StrComp(Mid(FName, InStrRev(FName, "") + 1), ThisWorkbook.Name) = 0 Then GoTo Skip

      'Open with the old password

      Set Wb = Workbooks.Open(FName, False, Password:=OldPassword)

      'Save with a new password

      Wb.SaveAs FName, Wb.FileFormat, NewPassword

      'Close the file

      Wb.Close

Skip:

    Next

    'Clean up

    With Application

      .ScreenUpdating = True

      .DisplayAlerts = True

      .EnableEvents = True

      .Calculation = xlCalculationAutomatic

    End With

  End With

  Exit Sub

Errorhandler:

  Dest = Array(Err.Number, FName)

  Set Dest = Dest.Offset(1)

  Resume Skip

End Sub

Was this answer helpful?

8 people found this answer helpful.
0 comments

2 additional answers

Sort by: Most helpful
Most helpful Newest Oldest
  1. Anonymous
    2019-11-10T18:40:42+00:00

    Thanks Andreas!

    Works like a charm!

    Jamie

    Was this answer helpful?

    0 comments
  2. Deleted

    This answer has been deleted due to a violation of our Code of Conduct. The answer was manually reported or identified through automated detection before action was taken. Please refer to our Code of Conduct for more information.

    Comments have been turned off. Learn more