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
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