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