VBA Help with password protecting my data cutting macro


New Member
Sep 19, 2014
I hope someone can help me with a very time saving macro that I use - PLEASE!!

It is a macro which I use on large sets of data to filter, copy, paste and save as new files. The macro works a charm and instead of manually copying and pasting filtered data for 100 or so line managers, you click the macro and it chops and saves the files in a specified folder where the data is saved.

However, what I would really like (for data security purposes etc etc) is when prompted by the macro on which column to apply the filters to, is to be asked if I want to add a password to all of the files ready to be chopped. Essentially, what I don't want to do is have to open each of the newly created spreadsheets and encrypt each one of them!! It is a huge pain in the proverbial.

If anyone could help, it would be massively appreciated. I've pasted the vba script below...

Option Explicit
' ============== Name =================
Dim wkCode As Workbook
Dim wkData As Workbook
Dim ColNumber As Integer
Const ValuesList = "ValuesList"
Sub SplitData()
On Error GoTo ErrHandling
Dim rngValue As Range
Dim rngColSplit As Range
Dim wkNew As Workbook
Set wkCode = ActiveWorkbook
'Open a workbook
Call OpenWkData
'ask for column number
ColNumber = InputBox("Which column number to split?")
'check column number is ok
If ColNumber < 1 Or ColNumber > wkData.Sheets(1).Range("A1").CurrentRegion.Columns.Count Then _
Err.Raise Number:=9998, Description:="Invalid Column Number"
'Create a unique list
Call CreateUniqList
'Work through a unique list
Application.ScreenUpdating = False
For Each rngValue In Range(ValuesList).Cells
'Filter firstsheet of wkDate
Range("A1").AutoFilter Field:=ColNumber, Criteria1:=rngValue.Value
'Create a new workbook
Set wkNew = ActiveWorkbook
'Copy and Paste data in new workbook, Columnswidths, Values then Formats

wkNew.Sheets(1).Range("a1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wkNew.Sheets(1).Range("a1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wkNew.Sheets(1).Range("a1").PasteSpecial Paste:=xlFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

'save workbook as filter value same location as wkData
Application.DisplayAlerts = False
wkNew.SaveAs Filename:=wkData.Path & "\" & rngValue.Value & ".xls", FileFormat:=xlExcel8
Application.DisplayAlerts = True
Next rngValue
Application.ScreenUpdating = True
MsgBox "Finished!!!! " & vbCrLf & wkCode.ActiveSheet.Range(ValuesList).Cells.Count & " files created", vbInformation, "Split data"
Exit Sub
MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & Err.Description, vbCritical, "Stopped"
End Sub
Sub OpenWkData()
Dim stFileName As String
'ask for filename
stFileName = Application.GetOpenFilename
'check to see if Cancel was pressed
If stFileName = "False" Then Err.Raise Number:=9999, Description:="No file was selected"
'open file
Workbooks.Open stFileName
Set wkData = ActiveWorkbook
End Sub
Sub CreateUniqList()
Dim rngColSplit As Range
Set rngColSplit = Range("A1").CurrentRegion.Columns(ColNumber)
Range(ValuesList).Offset(-1, 0).Select
rngColSplit.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveCell, Unique:=True
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.End(xlDown)).Name = ValuesList
End Sub

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

Forum statistics

Latest member

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