VBA and password protect sheet.

[esbjornsson]

Hi!
I have a question regarding the macro below. As you can see the macro loops trough a droplist and copy the sheet to a new one and saves it. My question is if it's possible to have the new sheets password protected? In my case I would like to have diffrent password for each file...

I'm getting Error 424 - Object Required, any idéa how to fix this one?

Sub Sammanfattning_Save()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Sammanställning").Select
 
 Dim rng As Range, cell As Range
 Set rng = Evaluate(ActiveSheet.Range("G1").Validation.Formula1)

t = rng(1, 1).Row

 For Each cell In rng
 
 ActiveSheet.Range("G1").Value = cell.Value
 Sheets("Sammanställning").Copy
    
    Dim FName           As String
    Dim FPath           As String
        
    FPath = "C:\Users\Hemma\Documents\My Dropbox\Kristofer\Jobb\Sammanställningar"
    FName = Sheets("Sammanställning").Range("G1").Text
    ActiveSheet.SaveAs Filename:=FPath & "\" & FName, Password:=Sheets("Password").Range("A1").Offset(cl.Row - t, 0).Value, ReadOnlyRecommended:=False, CreateBackup:=False
    
ActiveWindow.Close
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

I really hope you can help me with this one =)

Regards,
Christoffer

[nmhung49]

Password:=Sheets("Password").Range("A1").Offset(cl.Row - t, 0).Value

cl????????
Change

Password:=Sheets("Password").Range("A1").Offset(cell.Row - t, 0).Value

[davesexcel]

Try this,

activesheet.Protect Password:="123"
    ActiveSheet.SaveAs Filename:=FPath & "\" & FName, .........

[esbjornsson]

First, thanks for trying to help me =)
Hmm, changed cl to cell...

The error 424 has now change to "Subscript out of range (Error 9)"
Is it because of the Sheet.copy command?

@davesexcel: I want to have diffrent passwords assigned to the files... Security isn't important in this case. I have written all passwords in a a sheet called "Password".

[esbjornsson]

Sorry... The code you suggested will assign the same password to each file?

[nmhung49]

Can You post file? I think cells in yoursfile having special characters. With Protect in excel, Never a good way

[esbjornsson]

http://dl.dropbox.com/u/4400615/Samm...%20elever.xlsm
Hi again!
You can download the file from the url above.
Thanks!

[esbjornsson]

Thank you so much!

Have a nice day =)

[Davabb]

Hi i have done something similar with our timesheets here at work.
I give the user the ability to approve sheets then secure the worksheet after with a password.
Why are you looking to use different passwords. This can be done but may be a problem in future trying to unlock.

[esbjornsson]

Hi i have done something similar with our timesheets here at work.
I give the user the ability to approve sheets then secure the worksheet after with a password.
Why are you looking to use different passwords. This can be done but may be a problem in future trying to unlock.

Hi.
I'm a teacher and want to hand out results and attendance each week to the pupils parents. Thats why I don't want the same password for every file.
I upload the files to a dropbox-folder...

hi esbjornsson

If your problem is solve then Mark your thread as Solved

Done! Thanks for the reminder =)

[mohan.r1980]

Hi Friend,

i made some changes in your code
i fix the name in validation list because i got "Application error Problem" you may manage it

Sub Sammanfattning_Save()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Sammanställning").Select

Dim sPassword As String
Dim i As Integer
Dim shtPassword As Worksheet
Set shtPassword = Sheets("Password")
Dim shtSamm As Worksheet
Set shtSamm = Sheets("Sammanställning")

 Dim rng As Range, cell As Range
 Set rng = Evaluate(ActiveSheet.Range("G1").Validation.Formula1)
' Set rng = Evaluate(shtSamm.Range("G1").Validation.Formula1)
t = rng(1, 1).Row
i = 1

With shtPassword

    
         For Each cell In rng
         
         ActiveSheet.Range("G1").Value = cell.Value
         Sheets("Sammanställning").Copy
            
            Dim FName           As String
            Dim FPath           As String
            
            sPassword = .Range("A" & i).Value
            
            FPath = "C:\Documents and Settings\pdsys3\Desktop\New Folder"
            FName = Sheets("Sammanställning").Range("G1").Text
            ActiveSheet.SaveAs Filename:=FPath & "\" & FName, Password:=sPassword, ReadOnlyRecommended:=False, CreateBackup:=False
           
           i = i + 1
        
        ActiveWindow.Close
        Next
    
 End With

See attached file

[mohan.r1980]

hi esbjornsson

If your problem is solve then Mark your thread as Solved