VBA Code to split a column of factors into independent sheets. (VBA, Split, Sheets, Excel). Original code: http://www.rondebruin.nl/win/s3/win006_4.htm

Copy_To_Worksheets

Option Explicit

'Original code: http://www.rondebruin.nl/win/s3/win006_4.htm
Sub Copy_To_Worksheets()
    Dim CalcMode As Long
    Dim ws2 As Worksheet
    Dim WSNew As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim Lrow As Long
    Dim FieldNum As Long
    Dim My_Table As ListObject
    Dim ErrNum As Long
    Dim ActiveCellInTable As Boolean
    Dim CCount As Long

    'Select a cell in the column that you want to filter in the List or Table
    'Or use this line if you want to select the cell that you want with code.
    'In this example I select a cell in the Gender column
    'Remove this line if you want to use the activecell column
    'Application.GoTo Sheets("SplitInWorksheets").Range("C17")

    If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
        MsgBox "This macro is not working when the workbook or worksheet is protected", _
               vbOKOnly, "Copy to new worksheet"
        Exit Sub
    End If

    Set rng = ActiveCell

    'Test if rng is in a a list or Table
    On Error Resume Next
    ActiveCellInTable = (rng.ListObject.Name <> "")
    On Error GoTo 0

    'If the cell is in a List or Table run the code
    If ActiveCellInTable = True Then

        Set My_Table = rng.ListObject
        FieldNum = rng.Column - My_Table.Range.Cells(1).Column + 1

        'Show all data in the Table/List
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0

        With Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
        End With

        ' Add a worksheet to copy the a unique list and add the CriteriaRange
        Set ws2 = Worksheets.Add

        With ws2
            'first we copy the Unique data from the filter field to ws2
            My_Table.ListColumns(FieldNum).Range.AdvancedFilter _
                    Action:=xlFilterCopy, _
                    CopyToRange:=.Range("A1"), Unique:=True

            'loop through the unique list in ws2 and filter/copy to a new sheet
            Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
            For Each cell In .Range("A2:A" & Lrow)

                'Filter the range
                My_Table.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                                                                      Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

                CCount = 0
                On Error Resume Next
                CCount = My_Table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
                On Error GoTo 0

                If CCount = 0 Then
                    MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                         & vbNewLine & "It is not possible to copy the visible data to a new worksheet." _
                         & vbNewLine & "Tip: Sort your data before you use this macro.", _
                           vbOKOnly, "Split in worksheets"
                Else
                    Set WSNew = Worksheets.Add(after:=Sheets(Sheets.Count))
                    On Error Resume Next
                    WSNew.Name = cell.Value
                    If Err.Number > 0 Then
                        ErrNum = ErrNum + 1
                        WSNew.Name = "Error_" & Format(ErrNum, "0000")
                        Err.Clear
                    End If
                    On Error GoTo 0

                    'Copy the visible data and use PasteSpecial to paste to the new worksheet
                    My_Table.Range.SpecialCells(xlCellTypeVisible).Copy
                    With WSNew.Range("A1")
                        .PasteSpecial xlPasteColumnWidths
                        .PasteSpecial xlPasteValues
                        .PasteSpecial xlPasteFormats
                        Application.CutCopyMode = False
                        .Select
                    End With
                End If

                'Show all data in the Table/List
                My_Table.Range.AutoFilter Field:=FieldNum

            Next cell

            'Delete the ws2 sheet
            On Error Resume Next
            Application.DisplayAlerts = False
            .Delete
            Application.DisplayAlerts = True
            On Error GoTo 0

        End With

        If ErrNum > 0 Then MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" & vbNewLine & _
           "There are characters in the Unique name that are not allowed in a sheet name or the sheet exist."

        With Application
            .ScreenUpdating = True
            .Calculation = CalcMode
        End With
    Else
        MsgBox "Select a cell in the column of the List or Table that you want to filter"
    End If

End Sub