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