test new

'***--------------------Main Sub-------------------------***
Sub SplitIntoSheets()With Application
.ScreenUpdating = False
.DisplayAlerts = False
End WithThisWorkbook.Activate
Sheet1.Activate

    'clearing filter if any
    On Error Resume Next
    Sheet1.ShowAllData
    On Error GoTo 0

    Dim lsrClm As Long
    Dim lstRow As Long
    'counting last used row
    lstRow = Cells(Rows.Count, 1).End(xlUp).Row
    Dim uniques As Range
    Dim clm As String, clmNo As Long
    On Error GoTo handler
    clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.")
    clmNo = Range(clm & "1").Column
    Set uniques = Range(clm & "2:" & clm & lstRow)

'Calling Remove Duplicates to Get Unique Names
    Set uniques = RemoveDuplicates(uniques)
    Call CreateSheets(uniques, clmNo)

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .AlertBeforeOverwriting = True
        .Calculation = xlCalculationAutomatic
    End With
    Sheet1.Activate
    MsgBox "Well Done!"
    Exit Sub
    Data.ShowAllData

handler:
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .AlertBeforeOverwriting = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

'***---------------Gets Unique Names-----------------------***
Function RemoveDuplicates(uniques As Range) As Range
ThisWorkbook.Activate
    Sheets.Add
    On Error Resume Next
    ActiveSheet.Name = "uniques"
    Sheets("uniques").Activate
    On Error GoTo 0

    uniques.Copy
    Cells(2, 1).Activate
    ActiveCell.PasteSpecial xlPasteValues
    Range("A1").Value = "uniques"

    Dim lstRow As Long
    lstRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A2:A" & lstRow).Select
    ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo
    lstRow = Cells(Rows.Count, 1).End(xlUp).Row
    Set RemoveDuplicates = Range("A2:A" & lstRow)
End Function

***------------Creates Sheets-----------------------------***
Sub CreateSheets(uniques As Range, clmNo As Long)
    Dim lstClm As Long
    Dim lstRow As Long
    
    For Each unique In uniques
        Sheet1.Activate
        lstRow = Cells(Rows.Count, 1).End(xlUp).Row
        lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
        Dim dataSet As Range
        Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
        dataSet.AutoFilter field:=clmNo, Criteria1:=unique.Value
        lstRow = Cells(Rows.Count, 1).End(xlUp).Row
        lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
        Debug.Print lstRow; lstClm
        Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
        dataSet.Copy
        Sheets.Add
        ActiveSheet.Name = unique.Value2
        ActiveCell.PasteSpecial xlPasteAll
    Next unique
End Sub