Copy rows to a new sheet based on column criteria

[allgonzo]

I am trying to learn the best way to copy rows based on a column's criteria and name the worksheet accordingly. Below is more detail:
The information is pulled from our intranet site and saved as in excel 2003. The data fills A1:AA500. However this could vary each week. I need to copy all rows which have the same person's initials on column k into a new worksheet and name the worksheet the person's name. For example, if sheet one has 30 rows with ABC in column k, all 30 are copied to a new worksheet and the worksheet is named Albert (the A in ABC). Any help is truly appreciated. Not sure where to start.

 

[VoG]

Start here http://www.mrexcel.com/forum/showthread.php?t=396069

 

[allgonzo]

VoG,

Thanks for the reply. The code worked incredibly. I downloaded datapig, but it gummed up excel. It took for ever to open excel. I do have a follow-up question. Since the colunm that is used to create the other worksheets are initials, is there a way to have the worksheet name be the actual name of the person rather than the initials? Also, if I want to color the sheet a different color, can that be done? Thanks again.

 

[VoG]

If there's a column containing the names, not just the initials, you could use that to split by.

Do you mean colour the sheet tab or the sheet itself?

Please post the code that you are using as there are several variants in that thread.

 

[allgonzo]

Below is the code. For my purposes I changed the column "H" to "K". regarding coloring, I am looking only to color the sheet tab. I will probably lookup the names form another list that has the initials and names and insert a column with the information.

Sub Lapta()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
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:=Range("H2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To lastrow
If .Range("H" & i).Value <> .Range("H" & i + 1).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Range("H" & iStart).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[VoG]

Try this

Sub Lapta()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, iCol As Integer
iCol = 2
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:=Range("K2"), Order1:=xlAscending, _
    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    iStart = 2
    For i = 2 To lastrow
        If .Range("K" & i).Value <> .Range("K" & i + 1).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Range("K" & iStart).Value
            On Error GoTo 0
            iCol = iCol + 1: If iCol > 56 Then iCol = 3
            ws.Tab.ColorIndex = iCol
            ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub