I'm new here so please let me know if my post is incorrect or anything like that.
I currently have a macro that splits out one excel file into multiple files and saves them separately. This step I have found an answer to and am quite happy with.
I need these files to be password protected so when I email them out to clients I feel that they are being transmitted securely. Is there a macro that I can write/use to accomplish this trick for me.
My excel file Tab 1 houses all of my data and currently splits out everything based on column A.
John Test1 John Test2 John Test3 Alex Test4 Alex Test5 Frank Test6 Frank Test7
The macro I use splits this into separates file for John/Alex/Frank that shows only their data with none of the other individuals data.
I also have tab 2 that houses all of the passwords:
John Pw1 Alex Pw2 Frank Pw3
I am looking for a way to have the passwords listed in tab 2 to be applied to the newly created documents during the process of my current macro.
Any help on this would be greatly appreciated. Let me know if any of what I asked is unclear.
For reference I will quote the code I found from user mtone because this is the code I am currently using. This code has been very useful for me and I am extremely thankful to mtone for posting it. I don't believe I can send a private message to mtone but if I could I would thank him profusely!
Public Sub SplitToFiles() ' MACRO SplitToFiles ' Last update: 2012-03-04 ' Author: mtone ' Version 1.1 ' Description: ' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above ' ' Note: Values in the column should be unique or sorted. ' ' The following cells are ignored when delimiting sections: ' - blank cells, or containing spaces only ' - same value repeated ' - cells containing "total" ' ' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name. Dim osh As Worksheet ' Original sheet Dim iRow As Long ' Cursors Dim iCol As Long Dim iFirstRow As Long ' Constant Dim iTotalRows As Long ' Constant Dim iStartRow As Long ' Section delimiters Dim iStopRow As Long Dim sSectionName As String ' Section name (and filename) Dim rCell As Range ' current cell Dim owb As Workbook ' Original workbook Dim sFilePath As String ' Constant Dim iCount As Integer ' # of documents created iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1) iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1) iFirstRow = iRow Set osh = Application.ActiveSheet Set owb = Application.ActiveWorkbook iTotalRows = osh.UsedRange.Rows.Count sFilePath = Application.ActiveWorkbook.Path If Dir(sFilePath + "\Split", vbDirectory) = "" Then MkDir sFilePath + "\Split" End If 'Turn Off Screen Updating Events Application.EnableEvents = False Application.ScreenUpdating = False Do ' Get cell at cursor Set rCell = osh.Cells(iRow, iCol) sCell = Replace(rCell.Text, " ", "") If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then ' Skip condition met Else ' Found new section If iStartRow = 0 Then ' StartRow delimiter not set, meaning beginning a new section sSectionName = rCell.Text iStartRow = iRow Else ' StartRow delimiter set, meaning we reached the end of a section iStopRow = iRow - 1 ' Pass variables to a separate sub to create and save the new worksheet CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat iCount = iCount + 1 ' Reset section delimiters iStartRow = 0 iStopRow = 0 ' Ready to continue loop iRow = iRow - 1 End If End If ' Continue until last row is reached If iRow < iTotalRows Then iRow = iRow + 1 Else ' Finished. Save the last section iStopRow = iRow CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat iCount = iCount + 1 ' Exit Exit Do End If Loop 'Turn On Screen Updating Events Application.ScreenUpdating = True Application.EnableEvents = True MsgBox Str(iCount) + " documents saved in " + sFilePath End Sub Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long) Dim rngRange As Range Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow rngRange.Select rngRange.Delete End Sub Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat) Dim ash As Worksheet ' Copied sheet Dim awb As Workbook ' New workbook ' Copy book osh.Copy Set ash = Application.ActiveSheet ' Delete Rows after section If iTotalRows > iStopRow Then DeleteRows ash, iStopRow + 1, iTotalRows End If ' Delete Rows before section If iStartRow > iFirstRow Then DeleteRows ash, iFirstRow, iStartRow - 1 End If ' Select left-topmost cell ash.Cells(1, 1).Select ' Clean up a few characters to prevent invalid filename sSectionName = Replace(sSectionName, "/", " ") sSectionName = Replace(sSectionName, "\", " ") sSectionName = Replace(sSectionName, ":", " ") sSectionName = Replace(sSectionName, "=", " ") sSectionName = Replace(sSectionName, "*", " ") sSectionName = Replace(sSectionName, ".", " ") sSectionName = Replace(sSectionName, "?", " ") ' Save in same format as original workbook ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat ' Close Set awb = ash.Parent awb.Close SaveChanges:=False End Sub