Split data by column macro for Excel

SplitDataByCol.bas

Sub SplitDataByCol()
    Dim lastRow As Long
    Dim sourceWorksheet As Worksheet
    Dim columnToSplitBy As Integer
    Dim columnCount As Long
    Dim uniqueValues As Variant
    Dim headerRange As Range
    Dim splitColumnRange As Range
    Dim tempSheet As Worksheet
    Dim headerRowNumber As Integer
    Dim headerAddress As String
    Dim shortSheetName As String
    Dim i As Integer

    On Error Resume Next

    ' Get the header row range
    Set headerRange = Application.InputBox("Please select the header rows:", "Header Rows", Type:=8)
    If TypeName(headerRange) = "Nothing" Then Exit Sub

    ' Get the column range containing the split values
    Set splitColumnRange = Application.InputBox("Please select the column you want to split data based on:", "Split Column", Type:=8)
    If TypeName(splitColumnRange) = "Nothing" Then Exit Sub

    columnToSplitBy = splitColumnRange.Column
    Set sourceWorksheet = headerRange.Worksheet
    lastRow = sourceWorksheet.Cells(sourceWorksheet.Rows.Count, columnToSplitBy).End(xlUp).Row
    headerAddress = headerRange.AddressLocal
    headerRowNumber = headerRange.Cells(1).Row
    columnCount = sourceWorksheet.Columns.Count

    ' Create a unique values column
    sourceWorksheet.Cells(1, columnCount) = "Unique"
    Application.DisplayAlerts = False

    ' Create or reset the temporary sheet
    If Not Evaluate("=ISREF('TempSheet!A1')") Then
        Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "TempSheet"
    Else
        Sheets("TempSheet").Delete
        Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "TempSheet"
    End If

    Set tempSheet = Sheets("TempSheet")
    headerRange.Copy
    tempSheet.Paste Destination:=tempSheet.Range("A1")
    sourceWorksheet.Activate

    ' Populate unique values column
    For i = (headerRowNumber + headerRange.Rows.Count) To lastRow
        On Error Resume Next
        If sourceWorksheet.Cells(i, columnToSplitBy) <> "" And Application.WorksheetFunction.Match(sourceWorksheet.Cells(i, columnToSplitBy), sourceWorksheet.Columns(columnCount), 0) = 0 Then
            sourceWorksheet.Cells(sourceWorksheet.Rows.Count, columnCount).End(xlUp).Offset(1) = sourceWorksheet.Cells(i, columnToSplitBy)
        End If
    Next

    uniqueValues = Application.WorksheetFunction.Transpose(sourceWorksheet.Columns(columnCount).SpecialCells(xlCellTypeConstants))
    sourceWorksheet.Columns(columnCount).Clear

    ' Create sheets for each unique value and copy data
    For i = 2 To UBound(uniqueValues)
        sourceWorksheet.Range(headerAddress).AutoFilter Field:=columnToSplitBy, Criteria1:=uniqueValues(i) & ""
        shortSheetName = Left(uniqueValues(i), 21)

        If Not Evaluate("=ISREF('" & shortSheetName & "'!A1)") Then
            Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = shortSheetName
        Else
            Sheets(shortSheetName).Move After:=Worksheets(Worksheets.Count)
        End If

        tempSheet.Range(headerAddress).Copy
        Sheets(shortSheetName).Paste Destination:=Sheets(shortSheetName).Range("A1")
        sourceWorksheet.Range("A" & (headerRowNumber + headerRange.Rows.Count) & ":A" & lastRow).EntireRow.Copy Sheets(shortSheetName).Range("A" & (headerRowNumber + headerRange.Rows.Count))
        Sheets(shortSheetName).Columns.AutoFit
    Next

    tempSheet.Delete
    sourceWorksheet.AutoFilterMode = False
    sourceWorksheet.Activate
    Application.DisplayAlerts = True
End Sub