Attribute VB_Name = "SplitSheetTools"
Option Explicit

' Split one sheet into separate sheets by the values in a column
' Free module from sourabsaha.com
'
' Select the sheet you want to split, run the macro and enter the column
' number to split by (A = 1, B = 2 ...). The data must start in A1 with
' one header row. Each value gets its own sheet with the header row on top.

Public Sub SplitSheetByColumn()
    Dim src As Worksheet, dest As Worksheet, keys As Object
    Dim colNum As Variant, lastRow As Long, lastCol As Long, r As Long
    Dim key As Variant, sheetName As String

    Set src = ActiveSheet
    colNum = Application.InputBox("Split by which column number? (A = 1, B = 2 ...)", "Split sheet", 1, Type:=1)
    If colNum = False Then Exit Sub

    lastRow = src.Cells(src.Rows.Count, colNum).End(xlUp).Row
    lastCol = src.Cells(1, src.Columns.Count).End(xlToLeft).Column
    If lastRow < 2 Then
        MsgBox "No data found below the header row.", vbExclamation
        Exit Sub
    End If

    Set keys = CreateObject("Scripting.Dictionary")
    For r = 2 To lastRow
        key = CStr(src.Cells(r, colNum).Value)
        If Len(key) = 0 Then key = "Blank"
        If Not keys.Exists(key) Then keys.Add key, key
    Next r

    Application.ScreenUpdating = False
    For Each key In keys.keys
        sheetName = Left(SafeSheetName(CStr(key)), 31)
        If LCase(sheetName) = LCase(src.Name) Then sheetName = Left(sheetName, 25) & " split"
        Application.DisplayAlerts = False
        On Error Resume Next
        ActiveWorkbook.Worksheets(sheetName).Delete
        On Error GoTo 0
        Application.DisplayAlerts = True

        Set dest = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
        dest.Name = sheetName
        src.Range(src.Cells(1, 1), src.Cells(lastRow, lastCol)).AutoFilter Field:=colNum, Criteria1:=IIf(key = "Blank", "=", key)
        src.Range(src.Cells(1, 1), src.Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible).Copy dest.Range("A1")
        src.AutoFilterMode = False
        dest.Columns.AutoFit
    Next key
    src.Activate
    Application.ScreenUpdating = True
    MsgBox keys.Count & " sheet(s) created.", vbInformation
End Sub

Private Function SafeSheetName(ByVal txt As String) As String
    Dim bad As Variant
    For Each bad In Array("\", "/", "?", "*", "[", "]", ":")
        txt = Replace(txt, bad, "-")
    Next bad
    SafeSheetName = txt
End Function