Data to new worksheet

[Marchew]

Hi All,

I have a spreadsheet where in sheet1 I have employee names and their timesheet data. I also have a separate worksheet for each employee where I want to grab all data pertaining to the particular employee and paste it in their respective worksheet.
For Example - Sheet1
ColumnA | ColumnB | ColumnC
Name | Date | Task
Jack | 1/9/15 | Storeroom
Jack | 1/9/15 | Documentation
Bob | 2/9/15 | Documentation
Bob | 3/9/15 | Auditing

I would therefore like all of the rows for Jack to be on his Worksheet called Jack, Bobs on his Worksheet called Bob all within the same ColumnA/B/C on their sheet would be good. I can't have the employees sheets created on the fly as there will be other data on their sheet that can't be modified. This will be over in Columns F/G/H.

Thanks!!!!

 

[Takae]

Hope this helps.

Sub Marchew()
    Dim Dic, i As Long, LastR As Long
    Dim buf As String, keys
    Dim Mws As Worksheet, ws As Worksheet, Nws As Worksheet
    Dim flag As Long
    
    Application.ScreenUpdating = False
    Set Mws = Sheets("sheet1")
    With Mws
        Set Dic = CreateObject("scripting.Dictionary")
        On Error Resume Next
            LastR = Mws.Cells(Rows.count, 1).End(xlUp).row
        For i = 2 To LastR
            buf = Cells(i, 1).Value
            Dic.add buf, buf
        Next i
        keys = Dic.keys
        
        For i = 0 To Dic.count - 1
            For Each ws In Worksheets
                If ws.name = keys(i) Then
                    Set Nws = Sheets(keys(i))
                    flag = 1
                    Exit For
                End If
            Next
            
            If flag = 0 Then
                Set Nws = Worksheets.add()
                    Nws.name = keys(i)
            End If
            
            With ws
                LastR = .Cells(Rows.count, 1).End(xlUp).row
                Mws.Range("A1").AutoFilter Field:=1, Criteria1:=keys(i)
                Mws.Range(Mws.Range("A2"), Mws.Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 8).Copy
                .Cells(LastR + 1, 1).PasteSpecial Paste:=xlPasteValues
                flag = 0
            End With
        Next i
        Set Dic = Nothing
    End With
    Mws.Range("A1").AutoFilter
    Application.ScreenUpdating = True
    MsgBox "DONE"
End Sub

 

[My Aswer Is This]

Try this:

Sub Test()
Application.ScreenUpdating = False
Dim i As Integer
Dim Lastrow As Long
Dim Lastrow2 As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To Lastrow
Lastrow2 = Sheets(Cells(i, 1).Value).Cells(Rows.Count, "A").End(xlUp).Row + 1
Range(Cells(i, 1), Cells(i, 3)).Copy Destination:=Sheets(Cells(i, 1).Value).Cells(Lastrow2, 1)
Lastrow2 = Lastrow2 + 1
Next
Application.ScreenUpdating = True
End Sub

 

[Marchew]

Hi Takae and My Answer,

Tried both and they work perfectly!! Thank you both.

Very much appreciated.

Cheers,

March

 

[My Aswer Is This]

Glad I was able to help you. Come back here to Mr. Excel next time you need additional assistance.

Hi Takae and My Answer,

Tried both and they work perfectly!! Thank you both.

Very much appreciated.

Cheers,

March

 

[Marchew]

If I may ask about something further to the code Takae provided. How can it paste the original column widths also? Thanks!
With ws
LastR = .Cells(Rows.count, 1).End(xlUp).row
Mws.Range("A1").AutoFilter Field:=1, Criteria1:=keys(i)
Mws.Range(Mws.Range("A2"), Mws.Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 8).Copy
.Cells(LastR + 1, 1).PasteSpecial Paste:=xlPasteValues
flag = 0
End With

 

[Takae]

Mws.Range(Mws.Range("A2"), Mws.Range("A1").SpecialCells(xlCellTypeLastCell)).Resize(, 8).Copy
The "8" means Column H...Please change to "3".

One more modifiy...
>With Nws
Please add "N"

I have misunderstood again... my code will check if a sheet exists or not (and add).
Sorry, it is long idly.