Create Sheet Per Unique Value

Sub CreateSheetPerUniqueValue()
    ' Create Sheet Per Unique Value - vbacode.io
    ' This macro creates a new worksheet for each unique value in a specified column
    ' Perfect for: Student feedback sheets, client reports, regional data splits

    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim uniqueValues As Collection
    Dim cell As Range
    Dim uniqueValue As Variant
    Dim lastRow As Long
    Dim dataRange As Range
    Dim headerRow As Range
    Dim targetColumn As Long
    Dim sheetExists As Boolean
    Dim ws As Worksheet

    ' Configuration
    Set wsSource = ActiveSheet
    targetColumn = 1  ' Column A - change this to your target column (1=A, 2=B, etc.)

    ' Error handling
    On Error GoTo ErrorHandler

    ' Turn off screen updating for better performance
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' Find last row with data
    lastRow = wsSource.Cells(wsSource.Rows.Count, targetColumn).End(xlUp).Row

    ' Validate data exists
    If lastRow < 2 Then
        MsgBox "No data found. Make sure your data starts in row 2 (row 1 should be headers).", vbExclamation
        GoTo CleanUp
    End If

    ' Store header row
    Set headerRow = wsSource.Rows(1)

    ' Get unique values from target column
    Set uniqueValues = New Collection
    On Error Resume Next  ' Ignore duplicate errors
    For Each cell In wsSource.Range(wsSource.Cells(2, targetColumn), wsSource.Cells(lastRow, targetColumn))
        If Not IsEmpty(cell.Value) Then
            uniqueValues.Add cell.Value, CStr(cell.Value)  ' Key prevents duplicates
        End If
    Next cell
    On Error GoTo ErrorHandler

    ' Validate unique values found
    If uniqueValues.Count = 0 Then
        MsgBox "No unique values found in column " & Chr(64 + targetColumn) & ".", vbExclamation
        GoTo CleanUp
    End If

    ' Create sheets for each unique value
    For Each uniqueValue In uniqueValues
        ' Generate safe sheet name (Excel limit: 31 characters, no special characters)
        Dim sheetName As String
        sheetName = Left(CleanSheetName(CStr(uniqueValue)), 31)

        ' Check if sheet already exists
        sheetExists = False
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = sheetName Then
                sheetExists = True
                Exit For
            End If
        Next ws

        ' Create new sheet or clear existing one
        If sheetExists Then
            Set wsNew = ThisWorkbook.Worksheets(sheetName)
            wsNew.Cells.Clear
        Else
            Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            wsNew.Name = sheetName
        End If

        ' Copy header row
        headerRow.Copy wsNew.Range("A1")

        ' Copy filtered data
        Dim destRow As Long
        destRow = 2

        For Each cell In wsSource.Range(wsSource.Cells(2, targetColumn), wsSource.Cells(lastRow, targetColumn))
            If cell.Value = uniqueValue Then
                ' Copy entire row
                wsSource.Rows(cell.Row).Copy wsNew.Rows(destRow)
                destRow = destRow + 1
            End If
        Next cell

        ' Format new sheet
        With wsNew
            .Columns.AutoFit
            .Rows(1).Font.Bold = True
            .Rows(1).Interior.Color = RGB(68, 114, 196)  ' Blue header
            .Rows(1).Font.Color = RGB(255, 255, 255)  ' White text
        End With
    Next uniqueValue

    ' Success message
    MsgBox "Success! Created " & uniqueValues.Count & " worksheets." & vbCrLf & vbCrLf & _
           "Each sheet contains data for one unique value from column " & Chr(64 + targetColumn) & ".", vbInformation

CleanUp:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub

ErrorHandler:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Error: " & Err.Description & vbCrLf & vbCrLf & _
           "Please check your data and try again.", vbCritical
End Sub

Function CleanSheetName(rawName As String) As String
    ' Remove invalid characters for sheet names: / \ ? * : [ ]
    Dim cleanName As String
    cleanName = rawName
    cleanName = Replace(cleanName, "/", "-")
    cleanName = Replace(cleanName, "\", "-")
    cleanName = Replace(cleanName, "?", "")
    cleanName = Replace(cleanName, "*", "")
    cleanName = Replace(cleanName, ":", "-")
    cleanName = Replace(cleanName, "[", "(")
    cleanName = Replace(cleanName, "]", ")")
    CleanSheetName = Trim(cleanName)
End Function