VBA Help with password protecting my data cutting macro

cgp182

New Member
Joined
Sep 19, 2014
Messages
1
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
wkCode.Activate
For Each rngValue In Range(ValuesList).Cells
wkData.Activate
wkData.Sheets(1).Activate
'Filter firstsheet of wkDate
Range("A1").AutoFilter Field:=ColNumber, Criteria1:=rngValue.Value
'Create a new workbook
Workbooks.Add
Set wkNew = ActiveWorkbook
'Copy and Paste data in new workbook, Columnswidths, Values then Formats

wkData.Sheets(1).Range("A1").CurrentRegion.Copy
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
wkNew.Close
Next rngValue
Application.ScreenUpdating = True
MsgBox "Finished!!!! " & vbCrLf & wkCode.ActiveSheet.Range(ValuesList).Cells.Count & " files created", vbInformation, "Split data"
Exit Sub
ErrHandling:
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
wkData.Activate
Set rngColSplit = Range("A1").CurrentRegion.Columns(ColNumber)
wkCode.Activate
Range(ValuesList).Clear
Range(ValuesList).Offset(-1, 0).Select
rngColSplit.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveCell, Unique:=True
ActiveCell.Clear
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.End(xlDown)).Name = ValuesList
End Sub
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

Forum statistics

Threads
1,213,565
Messages
6,114,337
Members
448,568
Latest member
Honeymonster123

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