'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