Assigning passwords from a list to multiple files.

[Scotwho]

I have a workbook that through VBA parses a worksheet into separate workbooks based upon the criteria in a specified column and then names and saves the different workbooks. No problem, this macro works great. I then have another macro that sets each workbook a password from an assigned list based upon the name of the assigned name of the workbook. The problem is that the passwords won’t advance to the next in the list, they all get assigned the first password. I know I have something just out of order or something … I am still wet behind the ears with VBA .
Here is the password macro …

Sub ProtectAll()
 ActiveWorkbook.Sheets("Name_Change").Activate
    Dim wbk As Workbook
    Dim sFileSpec As String
    Dim sPathSpec As String
    Dim sFoundFile As String
    Dim sPW As String ' setting sPW as the Password String
    Dim TotalRow As Integer
    
    sPathSpec = "C:\Users\Test_Files\"
    sFileSpec = "*.xls"
    TotalRow = ActiveSheet.UsedRange.Rows.Count 'added to correct overflow error
    For V = 1 To TotalRow 'set the first row to row 2
    sFoundFile = Dir(sPathSpec & sFileSpec)
    Do While sFoundFile <> ""
    sPW = Cells(V + 1, 6).Value 'Get value of each cell in columns 6 start at row 2     
        Set wbk = Workbooks.Open(sPathSpec & sFoundFile)
        With wbk
            Application.DisplayAlerts = False
            wbk.SaveAs Filename:=.FullName, Password:=sPW
            Application.DisplayAlerts = True
        End With
        Set wbk = Nothing
        Workbooks(sFoundFile).Close False
        sFoundFile = Dir     
    Loop
    Next V
    ActiveWorkbook.Sheets("Front Sheet").Activate
    MsgBox "You have successfully set all the passwords"
End Sub

Thank you for any help ...

 

[wideboydixon]

It would use the password from F2 for every workbook right? Try this instead:

Sub ProtectAll()
    Dim wbk As Workbook
    Dim sFileSpec As String
    Dim sPathSpec As String
    Dim sFoundFile As String
    Dim sPW As String ' setting sPW as the Password String
    Dim passwordSheet As Worksheet
    Dim TotalRow As Long
    Dim passwordRow As Long
    
    Set passwordSheet = ActiveWorkbook.Sheets("Name_Change")
    TotalRow = passwordSheet.UsedRange.Rows.Count
    passwordRow = 2
    sPathSpec = "C:\Users\Test_Files\"
    sFileSpec = "*.xls"
    sFoundFile = Dir(sPathSpec & sFileSpec)
    Do While sFoundFile <> ""
        sPW = passwordSheet.Cells(passwordRow, 6).Value 'Get value of each cell in columns 6 start at row 2
        Set wbk = Workbooks.Open(sPathSpec & sFoundFile)
        With wbk
            Application.DisplayAlerts = False
            wbk.SaveAs Filename:=.FullName, Password:=sPW
            Application.DisplayAlerts = True
        End With
        Set wbk = Nothing
        Workbooks(sFoundFile).Close False
        sFoundFile = Dir
        passwordRow = passwordRow + 1
        If passwordRow > TotalRow Then passwordRow = 2 ' Loop around?
    Loop
    ActiveWorkbook.Sheets("Front Sheet").Activate
    MsgBox "You have successfully set all the passwords"
End Sub

You were very close! Not sure whether you want the line in red or not? Depends what you want to do if you run out of passwords ...

WBD

 

[Scotwho]

Thank you for the quick response.
It's still not advancing to the next password in the list however.
It's drawing the passwords from the original workbook and starts in column 6 and descending one at a time until complete keeping each one a unique password.
It's assigning all the file (47 in this run) the same password.

 

[wideboydixon]

Sub ProtectAll()
    Dim wbk As Workbook
    Dim sFileSpec As String
    Dim sPathSpec As String
    Dim sFoundFile As String
    Dim sPW As String ' setting sPW as the Password String
    Dim PasswordSheet As Worksheet
    Dim FrontSheet As Worksheet
    Dim TotalRow As Long
    Dim PasswordRow As Long
    
    Set PasswordSheet = ActiveWorkbook.Sheets("Name_Change")
    Set FrontSheet = ActiveWorkbook.Sheets("Front Sheet")
    TotalRow = PasswordSheet.Cells(PasswordSheet.Rows.Count, 6).End(xlUp).Row
    PasswordRow = 2
    sPathSpec = "C:\Users\Test_Files\"
    sFileSpec = "*.xls"
    sFoundFile = Dir(sPathSpec & sFileSpec)
    Do While sFoundFile <> ""
        sPW = PasswordSheet.Cells(PasswordRow, 6).Value 'Get value of each cell in columns 6 start at row 2
        Set wbk = Workbooks.Open(sPathSpec & sFoundFile)
        With wbk
            Application.DisplayAlerts = False
            wbk.SaveAs Filename:=.FullName, Password:=sPW
            Application.DisplayAlerts = True
        End With
        Set wbk = Nothing
        Workbooks(sFoundFile).Close False
        sFoundFile = Dir
        PasswordRow = PasswordRow + 1
        If PasswordRow > TotalRow Then PasswordRow = 2 ' Loop around?
    Loop
    FrontSheet.Activate
    MsgBox "You have successfully set all the passwords"
End Sub

Book1
	F
2	abc
3	def
4	ghi
Name_Change

As you can see I tested this with just 3 XLS files with three different simple passwords. I can confirm that each XLS file was saved with a different password. I'm not sure why it would set the same password 47 times.

WBD

 

[Scotwho]

New day, fresh eyes. I changed all my test passwords from sequential numbers for testing to the actual passwords and it works marvelously!! Not sure why that would matter, but it seemed to.
I like the cleanup that you did to the code as well, I must be more diligent in doing that.

Again, thank you for your help with this!
73's and fair skies

 

[wideboydixon]

I like the cleanup that you did to the code as well, I must be more diligent in doing that.

No problem. I try not to re-write stuff but instead "fit in" with the coding style of what's there when I can.

73's and fair skies

60 and drizzle.

WBD