This seems to be working well for me so far. 

Sub AnotherTestSplit()
Dim lastrow As Long
Dim LastCol As Integer
Dim i As Long
Dim iStart As Long
Dim iEnd As Long
Dim ws As Worksheet
Dim Master As String
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim s As Integer
Dim j As Integer
Dim ColLookup As String

Set rs = Application.InputBox(Prompt:="Select the Column for Lookup", Title:="Range Select", Type:=8)
ColLookup = rs.Address

 ColLookup = Left(rs.Address(False, False), 1 + -1 * (rs.Column > 26))

lastCell = Split(ActiveCell.Address, "$")(1) & Split(ActiveCell.Address, "$")(2)

Application.ScreenUpdating = False
With ActiveSheet
Master = .Name
    Application.DisplayAlerts = False
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> .Name Then ws.Delete
    Next ws
    Application.DisplayAlerts = True
    lastrow = .Cells(Rows.Count, ColLookup).End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Range(ColLookup & 2), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To lastrow
        If .Range(ColLookup & i).Value <> .Range(ColLookup & i + 1).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Range(ColLookup & iStart).Value
            On Error GoTo 0
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            With ws.Rows(1)
                .HorizontalAlignment = xlCenter
                With .Font
                  '  .ColorIndex = 5
                    .Bold = True
                End With
            End With
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
        
        For s = 1 To Sheets.Count - 1
       For j = s + 1 To Sheets.Count
          If StrComp(Sheets(s).Name, Sheets(j).Name) > 0 Then Sheets(j).Move Sheets(s)
       Next
    Next
      
        Next i
    
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets(Master).Activate
End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function