Excel VBA - Split files and password protect

CantGetRight

New Member
Joined
Jul 21, 2015
Messages
21
Hi all,

I have some code which allows me to split a workbook into multiple based upon a specific column. The code currently is dynamic in the sense that it asks the user to define the column number (Col A = 1, Col B = 2, Col C = 3, etc.) and define the row where the data begins. The names of the files are determined based on this column.

I want to amend this code so that is also asks you if you want to password protect the newly created workbooks. If yes is selected, similarly to defining the column to cut it up, it asks you to define the column with the unique password.

Any help would be greatly appreciated. The original data set example is below and the different outputs once the macro is run. The code I have functions great but want the pw addition added.

Thanks, Mark

Original Dataset
ABC
1NameEmailPassword
2Markmark@test.comMark123
3Markmark@test.comMark123
4Markmark@test.comMark123
5Johnjohn@test.comJohn123
6Michellemichelle@test.comMichelle123
7Michellemichelle@test.comMichelle123
8Stevesteve@test.comSteve123

Cutup 1
ABC
1NameEmailPassword
2Markmark@test.comMark123
3Markmark@test.comMark123
4Markmark@test.comMark123

Cutup 2
ABC
1NameEmailPassword
2Johnjohn@test.comJohn123

Cutup 3
ABC
1NameEmailPassword
2Michellemichelle@test.comMichelle123
3Michellemichelle@test.comMichelle123

Cutup 4
ABC
1NameEmailPassword
2Stevesteve@test.comSteve123


Public Sub SplitToFiles()

' MACRO SplitToFiles
' 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", 2, , , , , 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, "?", " ")
sSectionName = Strings.Trim(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
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

Forum statistics

Threads
1,223,885
Messages
6,175,179
Members
452,615
Latest member
bogeys2birdies

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top