Macro to Insert Unique Password for Multiple Excel Files

[ScottMsp]

Hello,

I have 200+ Excel files that I need to password protect with a unique
password for each file. I have the passwords prepared, I am not sure how to
write the macro to look at a list and set the password for each file to the
unique password I have assigned to it.

Thanks in advance.

 

[Bernie Deitrick]

Scott,

Do you have a list of the files as well?

Say you have a list of the workbooks' full names (including path) starting in cell A2, down column
A, with the proposed passwords in column B of the same row.

Then you could run the macro below.

If you don't have the file list, you could run the second macro below to create it.

HTH,
Bernie
MS Excel MVP

Sub AssignPasswords()
Dim myB As Workbook
Dim myPW As String
Dim myC As Range

For Each myC In Range("A2", Cells(Rows.Count, 1).End(xlUp))
myPW = myC.Offset(0, 1).Value
Set myB = Workbooks.Open(myC.Value)
myB.Protect Password:=myPW, Structure:=True, Windows:=False
myB.Save
Next myC

End Sub


Sub ListFiles()
Dim i As Integer

With Application.FileSearch
.NewSearch
.LookIn = "C:\Excel\Folder Name"
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & " file(s) found."
For i = 1 To .FoundFiles.Count
Cells(i + 1, 1).Value = .FoundFiles(i)
Next i
Else
MsgBox "There were no files found."
End If
End With
End Sub

 

[john]

not tested but following may do what you want.
code assumes that File name is in Col A with full path eg
C:\mydirectory\Filename.xls and password in Col B
but you can change code as required.

Sub SaveFilesWithPassword()
Dim FName As String
Dim Passwrd As String
Dim FListWs As Worksheet
Dim MyBook As Workbook


Set FListWs = Worksheets("Sheet1") '<<change as required

Application.DisplayAlerts = False

With FListWs

i = 1
Do While .Cells(i, 1).Value <> ""

FName = .Cells(i, 1).Value
Passwrd = .Cells(i, 2).Value

Set MyBook = Workbooks.Open(FName)

With MyBook

.SaveAs Filename:=FName, Password:=Passwrd

.Close False

End With

Loop

End With

Application.DisplayAlerts = True

End Sub

 

[Bernie Deitrick]

Forgot to close the file. After

myB.Save

insert

myB.Close

HTH,
Bernie
MS Excel MVP

 

[ScottMsp]

Bernie,

I did as instructed. The macro ran, but when I went to open up the file, no
password was required.

Thoughts?

 

[Jarek Kujawa]

Bern,
what might be the possible reason for below sub not working in my
Excel 2007? though it worked in Excel 2003

Sub ListFiles()
Dim i As Integer


With Application.FileSearch
.NewSearch
.LookIn = "C:\Excel\Folder Name"
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & " file(s) found."
For i = 1 To .FoundFiles.Count
Cells(i + 1, 1).Value = .FoundFiles(i)
Next i
Else
MsgBox "There were no files found."
End If
End With
End Sub

 

[ScottMsp]

Bernie,

I just realized that the macro you provided protects the workbook structure.

What I am looking for is a macro that saves a unique password for opening
the file (not changing the structure or protecting the sheet).

Thoughts?

 

[Bernie Deitrick]

Jarek,

Filesearch was removed from Excel 2007. The function Dir still works. Here's some example code....

Sub HowToUseDir()

Dim WorkFile As String
Dim colAT As Integer
Dim rowAT As Long
Dim booCHK As Boolean
Dim txtDIRECTORY As String
Dim strFILEEXT As String
Dim myBook As Workbook

txtDIRECTORY = "C:\Excel\" ' note final "\"

strFILEEXT = "*.xls"
colAT = 1
rowAT = 2
booCHK = True

If booCHK Then

WorkFile = Dir(txtDIRECTORY & strFILEEXT)

If WorkFile = "" Then
MsgBox "That folder is empty."
Exit Sub
End If

Do While WorkFile <> ""
'Create a listing
Cells(rowAT, colAT) = txtDIRECTORY & WorkFile
'If you want to open the file, use
'Set myBook = Workbooks.Open(txtDIRECTORY & WorkFile)
rowAT = rowAT + 1
WorkFile = Dir()
Loop


End If

End Sub


--
HTH,
Bernie
MS Excel MVP


Bern,
what might be the possible reason for below sub not working in my
Excel 2007? though it worked in Excel 2003

Sub ListFiles()
Dim i As Integer


With Application.FileSearch
.NewSearch
.LookIn = "C:\Excel\Folder Name"
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & " file(s) found."
For i = 1 To .FoundFiles.Count
Cells(i + 1, 1).Value = .FoundFiles(i)
Next i
Else
MsgBox "There were no files found."
End If
End With
End Sub

 

[Bernie Deitrick]

Sorry, no password is required to open the workbook based on that setting, just to change the
workbook's structure.

Add or change to

myB.Password = myPW 'Password To Open
myB.WritePassword = myPW 'Password to write


HTH,
Bernie
MS Excel MVP

 

[ScottMsp]

Bernie,

Thanks for patience, but one more question.

I am not sure what you are suggesting in your latest post, but I have made
an attempt to modify the macro based on some further research. Perhaps you
can recommend tweaks to it to make it run (currently it does not work).

Thanks again.

Sub AssignPasswords()
Dim myB As Workbook
Dim myPW As String
Dim myC As Range
Dim ws As Worksheet

For Each myC In Range("A2", Cells(Rows.Count, 1).End(xlUp))
myPW = myC.Offset(0, 1).Value
Set myB = Workbooks.Open(myC.Value)
myB.SaveAs Filename:="My File Path" & ws.Name, Password:=myPW
myB.Close
Next myC

End Sub

 

[ScottMsp]

I found the solution and thought I would post it. Thanks to Bernie for
leading the way...

Sub AssignPasswords()
Dim myB As Workbook
Dim myPW As String
Dim myC As Range
Dim ws As Worksheet

For Each myC In Range("A2", Cells(Rows.Count, 1).End(xlUp))
myPW = myC.Offset(0, 1).Value
Set myB = Workbooks.Open(myC.Value)
myB.Password = myPW
myB.Save
myB.Close
Next myC

End Sub

 

[Jarek Kujawa]

thks, heard sth. about that
I did not think of Dir as an alternative solution
thanks a lot, Bernie!