Option Explicit
Sub split_to_files()

Dim LR As Long, LREMAIL As Long, Itm As Long, MyCount As Long, vCol As Long, sumlr As Long
Dim ws As Worksheet, we As Worksheet, MyArr As Variant, vTitles As String, SvPath As String
Dim docmonth As String, docyear As String, path_f As String, savepath As String, fname As String
Dim StartTime As Double
Dim SecondsElapsed As Double

StartTime = Timer

path_f = ThisWorkbook.Path
savepath = path_f & "\To Send\"

'Sheet with data in it
   Set ws = Sheets("main")

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:G2"
   
'Choose column to evaluate from, column A = 1, B = 2, etc.
   'vCol = Application.InputBox("What column to split data by? " & vbLf _
   '     & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
   'If vCol = 0 Then Exit Sub

    vCol = 1
    
    
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
   

'Speed up macro execution

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False
    ActiveWindow.View = xlNormalView

'Get a temporary list of unique values from key column
    'ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True
    ws.Range("A1:A" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
        ws.Range("A1:H" & LR).Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Rows(1).Insert Shift:=xlShiftDown
        Rows(1).Insert Shift:=xlShiftDown
        Rows(1).Insert Shift:=xlShiftDown
        Rows(1).Insert Shift:=xlShiftDown
        Range("C1").Value = "Additional field:"
        Range("C1").Interior.ColorIndex = 6
        
        Cells.Columns.AutoFit
        
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 5
        
        
        'MyArr(Itm) = Replace(MyArr(Itm), "/", "")
        'MyArr(Itm) = Replace(MyArr(Itm), "\", "")
        'MyArr(Itm) = Replace(MyArr(Itm), ":", "")
        'MyArr(Itm) = Replace(MyArr(Itm), "=", "")
        'MyArr(Itm) = Replace(MyArr(Itm), "*", "")
        'MyArr(Itm) = Replace(MyArr(Itm), ".", "")
        'MyArr(Itm) = Replace(MyArr(Itm), "?", "")
        'MyArr(Itm) = Replace(MyArr(Itm), "{", "")
        'MyArr(Itm) = Replace(MyArr(Itm), "}", "")
        'MyArr(Itm) = Strings.Trim(MyArr(Itm))
     
        If Dir(savepath, vbDirectory) = "" Then
        MkDir savepath
        Else
        End If
        
        ActiveWorkbook.SaveAs savepath & MyArr(Itm) & ".xlsb", 50  '50 is binary format
        ActiveWorkbook.Close False
        
        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    ws.AutoFilterMode = False
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox SecondsElapsed & " Secs for processing"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False
    Application.StatusBar = False
End Sub