Sub SplitOutSheets1()
Dim LastRow As Long
Dim iStart As Long
Dim iEnd As Long
Dim i As Long
Dim LastCol As Long
Dim iCol As Integer
Dim ws As Worksheet
Dim r As Range
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
Application.ScreenUpdating = False
With ActiveSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort _
Key1:=Cells(2, iCol), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To LastRow
If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
iEnd = i
Sheets.Add After:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Cells(iStart, iCol).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value _
= .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
With ws.Rows(1)
.HorizontalAlignment = xlCenter
With .Font
.ColorIndex = 5
.Bold = True
End With
End With
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy _
Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
