How to Automatically Split Excel Data into Multiple Sheets Using VBA

Option Explicit 

' *** Module Overview *** 
' This module automates filtering data in a table and copying the filtered results 
' to new worksheets. 
' 
' ### Subroutines and Functions ### 
' 
' - Sub Filter_Table_To_Sheets: 
'   - Prompts the user to select a column to filter by. 
'   - Filters the table based on unique values in the selected column. 
'   - Creates new sheets for each unique value, copying the filtered data to them. 
'   - Handles user input for sorting and manages existing sheets with matching names. 
' 
' - Sub SortArray: 
'   - Sorts an array of values in either ascending or descending order using a 
'     simple sorting algorithm. 
' 
' - Function GetUniqueArray: 
'   - Extracts unique values from a specified range and returns them in an array. 
' 
' - Function CleanSheetName: 
'   - Cleans up sheet names by truncating to Excel's 31 character limit and 
'     replacing invalid characters to make them valid Excel sheet names. 
' 
' - Function EnsureUniqueSheetName: 
'   - Ensures that a sheet name is unique by adding a numeric suffix if needed. 
' 
' - Function SheetExists: 
'   - Checks if a worksheet with a given name already exists in the workbook. 
' 
' *** End of Module Overview *** 

Sub Filter_Table_To_Sheets() 
    Dim selectedCell As Range 
    Dim selectedTable As ListObject 
    Dim ws As Worksheet 
    Dim filterColumn As Range 
    Dim uniqueValues() As Variant 
    Dim i As Long 
    Dim newSheet As Worksheet 
    Dim copyRange As Range 
    Dim headerRange As Range 
    Dim existingSheetNames As Collection 
    Dim sheetName As Variant 
    Dim userResponse As VbMsgBoxResult 
    Dim cleanedSheetName As String 
    Dim sortOrder As String 
     
    ' Step 1: Ask the user to select a cell in the column they want to filter by 
    On Error Resume Next 
    Set selectedCell = Application.InputBox("Please select a cell in the column you want to filter by:", Type:=8) 
    On Error GoTo 0 
     
    ' Check if the user selected a cell 
    If selectedCell Is Nothing Then 
        MsgBox "No cell was selected. Exiting.", vbExclamation 
        Exit Sub 
    End If 
     
    ' Step 2: Check if the selected cell is part of a table 
    On Error Resume Next 
    Set selectedTable = selectedCell.ListObject 
    On Error GoTo 0 
     
    If selectedTable Is Nothing Then 
        MsgBox "The selected cell is not part of a table. Please select a valid table cell.", vbExclamation 
        Exit Sub 
    End If 
     
    ' Determine the column to filter by based on the selected cell 
    Set filterColumn = selectedTable.ListColumns(selectedCell.Column - selectedTable.Range.Column + 1).DataBodyRange 
     
    ' Step 3: Get all unique values in the selected column 
    uniqueValues = GetUniqueArray(filterColumn) 
     
    ' Step 4: Prompt the user to choose the sorting order (1 = A-Z, 2 = Z-A, 3 = Original) 
    sortOrder = Application.InputBox("Choose sorting order: 1 = A-Z, 2 = Z-A, 3 = Original", Type:=1) 
     
    ' Step 5: Handle the user's choice and sort accordingly 
    Select Case sortOrder 
        Case "1" 
            Call SortArray(uniqueValues, True) 
        Case "2" 
            Call SortArray(uniqueValues, False) 
        Case "3" 
            ' No sorting, keep original order 
        Case Else 
            ' Default to A-Z and notify the user 
            MsgBox "Invalid choice, defaulting to A-Z sorting.", vbInformation 
            Call SortArray(uniqueValues, True) 
    End Select 
     
    ' Step 6: Check for existing sheets with names matching the unique values 
    Set existingSheetNames = New Collection 
    For i = LBound(uniqueValues) To UBound(uniqueValues) 
        cleanedSheetName = CleanSheetName(CStr(uniqueValues(i))) 
        If SheetExists(cleanedSheetName) Then 
            existingSheetNames.Add cleanedSheetName 
        End If 
    Next i 
     
    ' Step 7: Ask the user if it's okay to delete the existing sheets 
    If existingSheetNames.Count > 0 Then 
        userResponse = MsgBox("There are existing sheets with the same names as the values in the chosen column. " &_ 
                              "Would you like to delete these sheets before proceeding?", vbYesNo + vbExclamation, "Delete Sheets") 
        If userResponse = vbYes Then 
            For Each sheetName In existingSheetNames 
                Application.DisplayAlerts = False ' Disable the prompt for deleting the sheet 
                ActiveWorkbook.Worksheets(sheetName).Delete 
                Application.DisplayAlerts = True ' Re-enable alerts after deletion 
            Next sheetName 
        Else 
            MsgBox "Process aborted. No sheets were deleted.", vbInformation 
            Exit Sub 
        End If 
    End If 
     
    ' Step 8: Get the header row of the table (if it exists) 
    Set headerRange = selectedTable.HeaderRowRange 
     
    ' Step 9: Create new sheets for each unique value and copy the filtered data 
    Application.ScreenUpdating = False 
    For i = LBound(uniqueValues) To UBound(uniqueValues) 
        cleanedSheetName = CleanSheetName(CStr(uniqueValues(i))) 
         
        ' Ensure unique sheet names 
        cleanedSheetName = EnsureUniqueSheetName(cleanedSheetName) 
         
        ' Apply filter based on the unique value 
        selectedTable.Range.AutoFilter Field:=filterColumn.Column - selectedTable.Range.Column + 1, Criteria1:=uniqueValues(i) 
         
        ' Identify the visible range after filtering 
        On Error Resume Next ' Handle case where no rows are visible 
        Set copyRange = selectedTable.DataBodyRange.SpecialCells(xlCellTypeVisible) 
        On Error GoTo 0 
         
        If Not copyRange Is Nothing Then 
            ' Create a new sheet and copy the filtered data 
            Set newSheet = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)) 
            newSheet.Name = cleanedSheetName 
             
            ' Copy the header row to the new sheet 
            If Not headerRange Is Nothing Then 
                headerRange.Copy Destination:=newSheet.Range("A1") 
            End If 
             
            ' Copy the filtered data to the new sheet 
            copyRange.Copy Destination:=newSheet.Range("A2") 
             
            ' Auto-fit columns in the new sheet 
            newSheet.Columns.AutoFit 
        End If 
    Next i 
    Application.ScreenUpdating = True 
     
    ' Clear the filter on the original table 
    selectedTable.AutoFilter.ShowAllData 
     
    MsgBox "Filtered data copied to new sheets for each unique value.", vbInformation 
End Sub 

Sub SortArray(ByRef arr() As Variant, ascending As Boolean) 
    ' Sorts an array either A-Z or Z-A 
    Dim i As Long, j As Long 
    Dim temp As Variant 
     
    ' Perform a simple bubble sort on the array 
    For i = LBound(arr) To UBound(arr) - 1 
        For j = i + 1 To UBound(arr) 
            If (ascending And arr(i) > arr(j)) Or (Not ascending And arr(i) < arr(j)) Then 
                ' Swap values in the array 
                temp = arr(i) 
                arr(i) = arr(j) 
                arr(j) = temp 
            End If 
        Next j 
    Next i 
End Sub 

Function GetUniqueArray(rng As Range) As Variant() 
    ' Function to retrieve unique values from a range and store them directly in an array 
    Dim cell As Range 
    Dim uniqueValues() As Variant 
    Dim isUnique As Boolean 
    Dim i As Long, j As Long 
    Dim currentValue As Variant 
     
    ' Initialize the uniqueValues array with an initial size of 1 
    ReDim uniqueValues(1 To 1) 
    i = 0 ' This will keep track of the number of unique values 
     
    ' Loop through each cell in the range 
    For Each cell In rng 
        currentValue = cell.value 
        If currentValue <> "" Then 
            ' Check if the value is already in the uniqueValues array 
            isUnique = True 
            For j = 1 To i 
                If uniqueValues(j) = currentValue Then 
                    isUnique = False 
                    Exit For 
                End If 
            Next j 
             
            ' If the value is unique, add it to the array 
            If isUnique Then 
                i = i + 1 
                ReDim Preserve uniqueValues(1 To i) 
                uniqueValues(i) = currentValue 
            End If 
        End If 
    Next cell 
     
    ' Return the array with unique values 
    GetUniqueArray = uniqueValues 
End Function 

Function CleanSheetName(sheetName As String) As String 
    ' Truncate the sheet name to 31 characters 
    sheetName = Left(sheetName, 31) 
     
    ' Replace invalid characters with underscores 
    sheetName = Replace(sheetName, "/", "_") 
    sheetName = Replace(sheetName, "\", "_") 
    sheetName = Replace(sheetName, "?", "_") 
    sheetName = Replace(sheetName, "*", "_") 
    sheetName = Replace(sheetName, ":", "_") 
    sheetName = Replace(sheetName, "[", "_") 
    sheetName = Replace(sheetName, "]", "_") 
     
    ' Remove apostrophes at the beginning or end of the name 
    If Left(sheetName, 1) = "'" Then sheetName = Mid(sheetName, 2) 
    If Right(sheetName, 1) = "'" Then sheetName = Left(sheetName, Len(sheetName) - 1) 
     
    ' Ensure the name is not blank 
    If sheetName = "" Then sheetName = "Sheet" 
     
    ' Avoid the reserved word "History" 
    If UCase(sheetName) = "HISTORY" Then sheetName = "History_Sheet" 
     
    CleanSheetName = sheetName 
End Function 

Function EnsureUniqueSheetName(sheetName As String) As String 
    Dim originalName As String 
    Dim counter As Integer 
     
    originalName = sheetName 
    counter = 1 
     
    ' Keep adding numbers until a unique name is found 
    While SheetExists(sheetName) 
        sheetName = originalName &"_" &counter 
        counter = counter + 1 
    Wend 
     
    EnsureUniqueSheetName = sheetName 
End Function 

Function GetUniqueValues(rng As Range) As Collection 
    ' Function to retrieve unique values from a range 
    Dim cell As Range 
    Dim uniqueValues As New Collection 
    Dim item As Variant 
     
    On Error Resume Next 
    For Each cell In rng 
        If cell.value <> "" Then 
            ' Attempt to add the item to the collection 
            uniqueValues.Add cell.value, CStr(cell.value) 
        End If 
    Next cell 
    On Error GoTo 0 
     
    Set GetUniqueValues = uniqueValues 
End Function 

Function SheetExists(sheetName As String) As Boolean 
    ' Function to check if a sheet with a given name exists 
    Dim ws As Worksheet 
    On Error Resume Next 
    Set ws = Worksheets(sheetName) 
    SheetExists = Not ws Is Nothing 
    On Error GoTo 0 
End Function