Sometimes, we need to prepare multiple workbooks on the basis of entries in a column. It is all the more useful in organizations where you need to send files to stakeholders. For example, in below sheet, you want to split the files on the basis of entries in column C. You may also like to prepare 3 files on the basis of entries in column D.
I wrote a macro which you can run to generate individual files. You just need to select a column or cell. If you select many columns, it will consider left most column. To run this macro, select the require column / cell, press ALT+F8 to invoke Macro window and run the macro (the file which you will need to download below should be open or macro should be copied in your workbook)
The file can be downloaded from FileSplitter
Sub FileSplitter()
Dim i As Long, Lr As Long, ColNum As Long, Cnt As Long, DictCount As Long
Dim Dict As Object
Dim Arr
Dim SWs As Worksheet
Dim Path As String
Dim Wk As Workbook
Application.StatusBar = ""
Set SWs = ActiveSheet
'Get Column number of the selection. In case of multi selection,
'get the left most column number
ColNum = Selection.Column
'If selected column doesn't contain a data, then give message. First row is header row
'hence < 2 condition
If WorksheetFunction.CountA(Columns(ColNum)) < 2 Then
MsgBox "The selected column doesn't contain data"
Exit Sub
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Use Dictionary to get a list of Unique items from selected column
Set Dict = CreateObject("Scripting.Dictionary")
Lr = SWs.Cells.SpecialCells(xlLastCell).Row
'Take the selected column values in an Array
ReDim Arr(1 To Lr – 1, 1 To 1)
Arr = SWs.Range(Cells(2, ColNum), Cells(Lr, ColNum))
'Run through all array entries and create a unique list
For i = 1 To Lr – 1
On Error Resume Next
Dict.Add Arr(i, 1), Arr(i, 1)
On Error GoTo 0
Next i
'Take the values of Dictionary in Arr
DictCount = Dict.Count
ReDim Arr(DictCount)
Arr = Dict.Items
Set Dict = Nothing
'Extract Path of this Excel workbook. All files will be saved there.
Path = ActiveWorkbook.Path
'Apply filter on the basis of Array entries and copy from here and paste into target workbook
'Target workbook name will be same as that of an Array entry
For i = LBound(Arr) To UBound(Arr)
'Open a new workbook where data can be copied
Set Wb = Workbooks.Add
SWs.AutoFilterMode = False
SWs.UsedRange.AutoFilter Field:=ColNum, Criteria1:=Arr(i)
SWs.AutoFilter.Range.Copy
Wb.Worksheets(1).Range("A1").PasteSpecial (xlPasteAll)
Wb.Worksheets(1).Range("A1").Select
'Allow only Alphabets and numbers in File Name. If any other character, replace that with nothing
'Trim(Arr(i)) has been used to remove a leading and trailing blanks in File name
Wb.SaveAs Filename:=Path & "\" & Trim(GetNewName(Arr(i))), FileFormat:=51
Wb.Close
Application.CutCopyMode = False
Cnt = Cnt + 1
Application.StatusBar = "Finished generating File " & Cnt & " of " & DictCount & " – " & Arr(i)
Next i
Application.StatusBar = DictCount & " files generated"
SWs.AutoFilterMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function GetNewName(InputStr)
'Allow only Alphabets and numbers in File Name. If any other character, replace that with space
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "[^a-zA-Z0-9]+"
End With
GetNewName = RegEx.Replace(InputStr, " ")
Set RegEx = Nothing
End Function