Macro to split workbook and password protect

[kbendelac]

I am looking to modify the macro below to add a password to each new workbook. I would like the password to be the same for each new file. Is this possible?

Sub WorkbookCreator()

Dim i As Integer 'Scans down Rows Data Sheet
Dim j As Integer 'Prints on New Workbooks
Dim z As String
Dim relativepath As String 'The Directory to save the files to

Dim Count As Integer
Dim Vendor As String

Dim WB As Workbook
Set WB = ActiveWorkbook 'References This Workbook

Dim WS As Worksheet
Set WS = ActiveSheet 'References this Worksheet

Dim WB1 As Workbook 'Assigned to Workbooks being created
Dim WS2 As Worksheet

Count = 0

z = InputBox("Which Quarter and Year", "Ex 'Q3-2014'")

'Find Size of List
ListSize = 6
Do Until WS.Cells(ListSize, 1).Value = Empty
ListSize = ListSize + 1
Loop
VendorCount = 0
i = 6
Vendor = WS.Cells(i, 1).Value

Do Until WS.Cells(i, 1).Value = Empty

Vendor = WS.Cells(i, 1).Value
VendorCount = VendorCount + 1
j = 6

'Create the New Workbook
Set WB1 = Workbooks.Add

'Copy OverSheet into NewWorkbook
WS.Copy Before:=WB1.Sheets(1)
WB1.Sheets(1).Name = Vendor

'Trim to Until Vendor Starts
If i > 6 Then
WB1.Sheets(1).Range("A" & j & ":A" & (i - 1)).EntireRow.Delete
End If

'Keep the Vendor Rows and Count
Do Until WB1.Sheets(1).Cells(j, 1) <> Vendor Or _
WB1.Sheets(1).Cells(j, 1) = Empty
j = j + 1
i = i + 1
Count = Count + 1
Loop

'Trim the Rest
WB1.Sheets(1).Range("A" & j & ":A" & ListSize).EntireRow.Delete

'Save the New Workbook to Current Directory
relativepath = WB.Path & "\" & "2021 Salary Increase Letter - " & Replace(Vendor, ".", "") & " - " & z

WB1.SaveAs Filename:=relativepath

WB1.Close

Loop

MsgBox (VendorCount & " Vendor Files Printed")
MsgBox ((ListSize - 6) & " items on file, " & Count & " items printed")
End Sub

 

[severynm]

After you set up the workbook, call Workbook.Protect on the workbook and provide a password. Otherwise, if you'd rather manage the protection at a sheet level, you could borrow one of the examples from here.