Loop to PW Protect files in Folder with Unique PWs from list

[Von Julmust]

Hello,

I have 97 files in a specific folder, I would like to password protect each of these files with different passwords (ideally using a list).

I have a Worksheet in a Workbook that lists all the files in Column A and then the password in Column B.

Any ideas how to create this loop would be appreciated (an automatic way to generate a list of files in folder for a Worksheet would be neat too, I have some pretty badly written VBA that does this already).

Best,
V

 

[breynolds0431]

Hi. This takes about 2-3 seconds per file for my testing. I'd imagine even longer on a network path. Using this method, each file is opened and the password is applied prior to closing. There is also a sub to grab all the file names from the specific folder. Notice the constant strings used for the folder path and the worksheet to save the filenames to.

'Update the below constants
'oPath will be the path with your 97 files - remember to
'include the slash at the end
Const oPath As String = "C:\Users\reyno\Documents\97Files\"
'sName will be the sheet name of the sheet with the filenames
'and passwords
Const sName As String = "Sheet1"

Sub getfilenames()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(sName)
Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim oFolder As Object: Set oFolder = oFSO.getfolder(oPath)
Dim oFile As Object, i As Integer

'set your first row - if you have a header use 2
i = 2

'loops through oFolder and adds each filename to sName, column A
For Each oFile In oFolder.Files
    ws.Cells(i, 1) = oFile.Name
    i = i + 1
Next oFile

End Sub

Sub loopandlock()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(sName)
Dim lrow As Long: lrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim c As Range, pw As String, xWB As Workbook

'Optimize processing
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

'error handling
On Error GoTo rThings

'loops through workbook names in column A, beginning on row 2
For Each c In ws.Range("A2:A" & lrow).Cells
    If Not ws.Cells(c.Row, 2).Value = vbNullString Then
    'As long as there's a password on the same row, code runs
        'sets password based on current row's column B
        pw = ws.Cells(c.Row, 2).Value
        'opens workbook
        Set xWB = Workbooks.Open(Filename:=oPath & c.Value, ReadOnly:=False)
        Application.DisplayAlerts = False
        'saves with the applicable password and then closes
        With xWB
            .Activate
            .SaveAs oPath & c.Value, , pw
            .Close
        End With
        Application.DisplayAlerts = True
    End If
Next c

'Restores settings
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

'Task completion message
MsgBox "The task has completed.", vbInformation, "Task Completion"

Exit Sub

'Error Handling
rThings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub