Password Protect Multiple Excel files

You can use the below vba code (posted here by Justin Hampton) to add a password to multiple Excel files in a single folder.


Open a blank workbook, and press ALT + F11. Enter the below visual basic code in a new module, by right clicking on the workbook name in the Project List, and selecting Insert . . . Module


Specify the directory containing your files on the line beginning 'folderPath'.

Enter a password on the line beginning 'Filename:=Application.'.


Run the macro and the files will be protected. When they are next opened, the user will be prompted to enter a password.


As always, I tested this technique tonight using test data, and confirmed that it works.





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:\foofolder\test4"
    Set folder = FSO.GetFolder(folderPath)
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
    End With
        
    For Each wb In folder.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:="DogCat2020"
            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:="yourpassword"
                ActiveWorkbook.Close True
            End If
        Next
    Next
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With
End Sub