Automatisch wachtwoord op bestand

[Markowitz]

Hoi allemaal,

Mijn eerste post en gelijk een stevig verzoek. Daarom laat ik ook mijn macro's zien zodat wellicht anderen er iets aan hebben...

Voor mijn werk krijgen we data aangeleverd met 10 duizenden regels die we op basis van een waarde gesplitst willen hebben (so far so good). Want daar heb ik een macro voor kunnen schrijven:

Sub Markowitz_1()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With ActiveSheet
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Range("A2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To lastrow
If .Range("A" & i).Value <> .Range("A" & i + 1).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Range("L" & iStart).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Deze macro splitst ze in hetzelfde werkboek. Vervolgens zorgt de volgende macro ervoor dat elk apart worksheetje wordt opgeslagen, weer so far so good:

Sub markowitz2()

Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Maar nu wil ik graag dat er op de worksheet een automatisch wachtwoord wordt gezet (voor alle 200 worksheetjes dezelfde). Ik krijg het niet voor elkaar want doe ik dat voordat ze worden opgeslagen Sub Markowitz2 werkt vervolgens het opslaan niet meer. Erna opslaan weet ik geen macro voor...

Wie o wie heeft een idee...Help…

 

[Markowitz]

Het probleem is opgelost...

Hierbij de macro voor diegene die geinteresseerd zijn.

Sub Markowitz3()

Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Columns("A:AZ").EntireColumn.AutoFit

Dim Rng As Range
Dim c As Range
Set Rng = Range("V2:V" & Range("V2").End(xlDown).Row)
Set c = Range("V2").End(xlDown).Offset(1, 0)
c.Formula = "=SUM(" & Rng.Address(False, False) & ")"

Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name, FileFormat:=56, Password:="XXX", WriteResPassword:="", ReadOnlyRecommended:=False
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub