VBA Macro to Filter with Input box, Split files, Convert into Excel Table and Sort

Change first part to

Sub Filter_Split()
Dim wbDest As Workbook, rngFilter As Range, rngUniques As Range, cell As Range
    
mycol = InputBox("Witch Column ?")
Set rngFilter = Range(mycol & "1", Range(mycol & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
With rngFilter
    .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Set rngUniques = Range(mycol & "1", Range(mycol & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
    ' Clear the filter
    ActiveSheet.ShowAllData
End With

Kind regards
Leo

Compleet

Sub Filter_Split()
Dim wbDest As Workbook, rngFilter As Range, rngUniques As Range, cell As Range
    
mycol = InputBox("Witch Column ?")
Set rngFilter = Range(mycol & "1", Range(mycol & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
With rngFilter
    .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Set rngUniques = Range(mycol & "1", Range(mycol & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
    rngUniques.Copy Sheets("blad1").Range("C1")
    ' Clear the filter
    ActiveSheet.ShowAllData
End With
For Each cell In rngUniques
    Set wbDest = Workbooks.Add(xlWBATWorksheet)
    rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
    rngFilter.EntireRow.Copy
    With wbDest.Sheets(1).Range("A1")
            .PasteSpecial xlPasteColumnWidths           'Paste column widths
            .PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
            .PasteSpecial Paste:=xlPasteFormats         'Paste formats ######
    End With
    Application.CutCopyMode = True
        
        'completely added by me on 8 nov 2015
        
        'For copy Title
'        ThisWorkbook.Sheets(1).Range("A1:H5").Copy
        
        'For Paste Title
'        With wbDest.Sheets(1).Range("A1:H5")
 '           .PasteSpecial xlPasteColumnWidths           'Paste column widths
  '          .PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
   '         .PasteSpecial Paste:=xlPasteFormats         'Paste formats ######
    '    End With
        
        'For Copy End Lines
     '   ThisWorkbook.Worksheets("Sheet1").Range("A19:H22").Copy
        
        'For Paste End Lines at the end of the Sheet
      '  wbDest.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Select
       ' ActiveSheet.Paste
            
        
        
        'For page Setup
        ActiveSheet.PageSetup.PrintArea = myRange
        With ActiveSheet.PageSetup
            .PrintTitleRows = ""
            .PrintTitleColumns = ""
            .LeftMargin = Application.InchesToPoints(0.2)
            .RightMargin = Application.InchesToPoints(0.2)
            .TopMargin = Application.InchesToPoints(0.5)
            .BottomMargin = Application.InchesToPoints(0.5)
            .HeaderMargin = Application.InchesToPoints(0.2)
            .FooterMargin = Application.InchesToPoints(0.2)
            .PaperSize = xlPaperA4
            .Orientation = xlLandscape 'xlPortrait
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1
'            .PrintTitleRows = "$1:$6"
            '.PrintArea = "$A$1:$K$57"
            .LeftFooter = "&""Cambria,Regular""&11Fahad Insaf-Distribution Department"
            .CenterFooter = "&""Cambria,Regular""&11PharmEvo (Pvt.) LTD."
 '           .RightFooter = "&""Cambria,Regular""&11Page &P of &N"
            .CenterHorizontally = True
            .CenterVertically = False
        End With
        
        
        
        ' {END} completely added by me on 8 nov 2015
        
        ' Name the destination sheet
        wbDest.Sheets(1).Name = cell.Value
        ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = "Tabel1"
        ActiveWorkbook.ActiveSheet.ListObjects("Tabel1").Sort.SortFields.Add _
        Key:=Range("Tabel1[B. Assigned to MS]"), SortOn:=xlSortOnValues, Order:= _
        xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.ListObjects("Tabel1").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("E" & Rows.Count).End(xlUp).Offset(2).FormulaR1C1 = "=SUM(Tabel1[B. Assigned to MS])"
    Range("D" & Rows.Count).End(xlUp).Offset(2) = "Total"

        
        'Save the destination workbook and close
        
       
        'Added By Fahad
'        wbDest.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path _
 '       & Application.PathSeparator & cell.Value, _
  '      Quality:=xlQualityStandard, IncludeDocProperties:=True, _
   '     IgnorePrintAreas:=False, OpenAfterPublish:=False
        
        wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
            cell.Value
        wbDest.Close False 'Close the new workbook
    Next cell
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

Kind regards
Leo

I forgot to remove that line, you dont need it


Kind regards
Leo

So 1 inputbox for Column to create the Files
and 1 inputbox to say on witch Column to sort

and in inputbox the columnheaders or A,B,C ..... ?

Kind regards
Leo

Try this and let me know

Sub Filter_Split()
Dim wbDest As Workbook, mystring As String, mycol As String, mycolnr1 As Integer, mycolnr2 As Integer, ws As Worksheet
Set ws = Sheets("Sheet1")
ws.Range("A1").CurrentRegion.Copy
Application.ScreenUpdating = False
With Sheets.Add
    .Name = "Temp"
    .PasteSpecial xlPasteColumnWidths
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .LeftMargin = Application.InchesToPoints(0.2)
        .RightMargin = Application.InchesToPoints(0.2)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .HeaderMargin = Application.InchesToPoints(0.2)
        .FooterMargin = Application.InchesToPoints(0.2)
        .PaperSize = xlPaperA4
        .Orientation = xlLandscape 'xlPortrait
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        '.PrintTitleRows = "$1:$6"
        '.PrintArea = "$A$1:$K$57"
        .LeftFooter = "&""Cambria,Regular""&11Fahad Insaf-Distribution Department"
        .CenterFooter = "&""Cambria,Regular""&11PharmEvo (Pvt.) LTD."
        '.RightFooter = "&""Cambria,Regular""&11Page &P of &N"
        .CenterHorizontally = True
        .CenterVertically = False
    End With
End With
arr = ws.Range("A1").CurrentRegion
ReDim sn(1 To UBound(arr), 1 To UBound(arr, 2))
mycol = InputBox("Witch Column for Creation of files ?")
mycol2 = InputBox("Witch Column for Sorting ?")
mycolnr2 = ws.Range(mycol2 & "1").Column
mycolnr1 = ws.Range(mycol & "1").Column
For x = 2 To UBound(arr)
    If InStr(1, mystring, arr(x, mycolnr1)) = 0 Then
        ws.Range("A1").CurrentRegion.AutoFilter mycolnr1, Criteria1:=arr(x, mycolnr1)
        mystring = mystring & " " & arr(x, mycolnr1)
        ws.Range("A1").CurrentRegion.SpecialCells(12).Copy Sheets("Temp").Range("A1")
        Sheets("Temp").Range("A1").CurrentRegion.Sort Key1:=Range(mycol2 & "1"), Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        Sheets("Temp").Copy
        ActiveSheet.Name = arr(x, mycolnr1)
        ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = "Tabel1"
        Range("E" & Rows.Count).End(xlUp).Offset(2).FormulaR1C1 = "=SUM(Tabel1[B. Assigned to MS])"
        Range("D" & Rows.Count).End(xlUp).Offset(2) = "Total"
        ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & arr(x, mycolnr1)
        ActiveWorkbook.Close
        ws.Range("A1").CurrentRegion.AutoFilter
        Sheets("Temp").Range("A1").CurrentRegion.Clear
    End If
Next
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Kind regards
Leo