Copy Each Row Associated With Name To New Sheets

[vmc62]

Hi,

Before I explain my problem, I should let you all know that I posted this same question on another forums, and this is the link to that forum (which it hasn't had an answer yet)

http://www.excelforum.com/showthread.php?t=642781


Also in this forum, where I got some responses to my issue and appreciate them, however I tried many times modifying what they suggested and still doesn't work in my situation.

http://www.ozgrid.com/forum/showthread.php?p=431691#post431691


I will describe my problem now as clear as possible. I'm making a Task list with assignments for each of my team members. Columns A & B describes the ID number of the task, Column C describes the Task itself, Columns D to J are hidden, Column K describes the author of the task.


Column L is the one that have the name (or names) of the person who is in charge of doing that task. What I need to do is to create a macro that searches the name of that person in Column L and once it finds it it will create another sheet with the name of that person. And add to that sheet the entire row of his task.

For example:
|-----------------------------------------------------------------|
|-A-|-B-|--------C---------|---K---|----L------|
|-----------------------------------------------------------------|
|---1---|-----Project A-----|
|--1.01-|-Approve Invoices--|--Jim--|---Dave---|
|--1.02-|--SCC Agreement---|--Jim--|---Victor--|
|-----------------------------------------------------------------|
|-----------------------blank row---------------------------------|
|-----------------------------------------------------------------|
|---2----|-----Project B-----|
|--2.01--|--Planning meeting-|--Jim--|---Victor--|
|--2.02--|-Database update--|--Jim--|---Victor--|
|--2.03--|-Master agreement-|--Jim--|-Victor, Dave-|
|-----------------------------------------------------------------|


This macro should do rename Sheet2 as 'Dave' and it'd contain:
|-----------------------------------------------------------|
|-A-|-B-|--------C--------|--K--|
|-----------------------------------------------------------|
|---1---|----Project A-----|-----|
|--1.01-|-Approve Invoices-| Jim |
|-----------------------------------------------------------|
|------------------------blank row--------------------------|
|-----------------------------------------------------------|
|---2---|----Project B------|-----|
|--2.03-|-Master agreement-| Jim |
|-----------------------------------------------------------|

Then it should rename Sheet3 as 'Victor' and it'd contain:
|-----------------------------------------------------------------|
|-A-|-B-|--------C----------|---K---|
|---1---|-----Project A------|-------|
|--1.02-|--SCC Agreement---|--Jim--|
|-----------------------------------------------------------------|
|-----------------------------------------------------------------|
|---2----|-----Project B-----|---K---|
|--2.01--|--Planning meeting-|--Jim--|
|--2.02--|-Database update--|--Jim--|
|--2.03--|-Master agreement-|--Jim--|
|-----------------------------------------------------------------|


...and it should do the same for any names in the cells of that column, and each cell can contain up to 3 names separated by a comma. Once I run this macro again it should update the information of each sheet created.

I'm new to macros-vba. I don't understand it much, but I found this code online :

Sub PagesByDescription()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String

    Set wSheetStart = ActiveSheet
    wSheetStart.AutoFilterMode = False
    'Set a range variable to the correct item column
    Set rRange = Range("L9", Range("L65536").End(xlUp))
    
        'Delete any sheet called "UniqueList"
        'Turn off run time errors & delete alert
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("UniqueList").Delete
        
        'Add a sheet called "UniqueList"
        Worksheets.Add().Name = "UniqueList"
        
           'Filter the Set range so only a unique list is created
            With Worksheets("UniqueList")
                rRange.AdvancedFilter xlFilterCopy, , _
                 Worksheets("UniqueList").Range("A1"), True
                 
                 'Set a range variable to the unique list, less the heading.
                 Set rRange = .Range("A2", .Range("A65536").End(xlUp))
            End With
            
            On Error Resume Next
            With wSheetStart
                For Each rCell In rRange
                  strText = rCell
                 .Range("A1").AutoFilter 1, strText
                    Worksheets(strText).Delete
                    'Add a sheet named as content of rCell
                    Worksheets.Add().Name = strText
                    'Copy the visible filtered range _
                    (default of Copy Method) and leave hidden rows
                    .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
                    ActiveSheet.Cells.Columns.AutoFit
                Next rCell
            End With
            
        With wSheetStart
            .AutoFilterMode = False
            .Activate
        End With
        
        On Error GoTo 0
        Application.DisplayAlerts = True
        
End Sub

And I tried this one:

Sub SearchForString()
     
    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer
     
    On Error GoTo Err_Execute
     
     'Start search in row 4
    LSearchRow = 9
     
     'Start copying data to row 2 in Sheet2 (row counter  variable)
    LCopyToRow = 2
     
    While Len(Range("A" & CStr(LSearchRow)).Value) >= 0
         
         'If value in column E = "Mail Box", copy entire row to Sheet2
        If Range("L" & CStr(LSearchRow)).Value = "Jim" Then
             
             'Select row in Sheet1 to copy
            Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
            Selection.Copy
             
             'Paste row into Sheet2 in next row
            Sheets("Sheet2").Select
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste
             
             'Move counter to next row
            LCopyToRow = LCopyToRow + 1
             
             'Go back to Sheet1 to continue searching
            Sheets("Sheet1").Select
             
        End If
         
        LSearchRow = LSearchRow + 1
         
    Wend
     
     'Position on cell A3
    Application.CutCopyMode = False
    Range("A3").Select
     
     MsgBox "All matching data has been copied."
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred."
     
End Sub

I tried this other one:

Sub GetIt()
    Dim sheetA As Worksheet, sheetB As Worksheet
    Dim wb As Workbook
    Dim i As Long, k As Long
    Set wb = ActiveWorkbook
    Set sheetA = wb.Sheets(1)
     
    i = 9
    On Error Resume Next
    With sheetA
        While Not IsEmpty(.Cells(i, 5).Value)
            Set sheetB = wb.Sheets(.Cells(i, 5))
            If sheetB Is Nothing Then
                wb.Sheets.Add After:=wb.Sheets(wb.Sheets.Count)
                Set sheetB = wb.ActiveSheet
                sheetB.Name = .Cells(i, 5)
                .Rows(2).Copy sheetB.Rows(1)
            End If
            k = sheetB.Range("B65536").End(xlUp).Row + 1
             
            .Rows(i).Copy sheetB.Rows(k)
            i = i + 1
            Set sheetB = Nothing
        Wend
    End With
End Sub

And I just tried this last one:

Sub ExtractToSheets()
    Dim ws     As Worksheet
    Dim wsNew  As Worksheet
    Dim rData  As Range
    Dim rCl    As Range
    Dim sNm    As String
    Set ws = Worksheets("Sheet1")
    Set rData = ws.Range("a1", ws.Range("z65536").End(xlUp))
     
     'extract a list of unique names
    ws.Range("L9", Range("l65536").End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("i1"), Unique:=True
     
    For Each rCl In ws.Range("i1", ws.Range("i65536").End(xlUp))
        sNm = rCl.Text
         'add new sheet (only if required-NB uses  UDF)
        If WksExists(sNm) Then
            Sheets(sNm).Cells.Clear
        Else
            Set wsNew = Sheets.Add
            wsNew.Move After:=Worksheets(Worksheets.Count) 'move to end
            wsNew.Name = sNm
        End If
         'AutoFilter & copy to relevant sheet
        rData.AutoFilter Field:=2, Criteria1:=sNm
        rData.Copy Destination:=Worksheets(sNm).Range("a1")
    Next rCl
    ws.Columns(9).Delete 'remove temporary list
    rData.AutoFilter 'switch off AutoFilter
End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

I'm new to Excel macros-vba, I'm trying to modify any of this codes to work for my problem, but I cannot seem to achieve it. Also, if the code encounter in a the cell more than one name (e.g. Victor,Mike,Jim) instead of copying that row of information to their respective individual sheets, it creates a sheet with those names, and pastes all information there, and that's not what I want.
Here is the link to the file of the Task List itself for your assistance in helping me.

http://cid-d22788d315f0fa0a.skydrive.live.com/browse.aspx/Public

Thank you in advance for your help.

 

[stanleydgromjr]

vmc62,

Please post a screenshot of your sheet(s), what you have and what you expect to achieve, with Excel Jeanie HTML 4.
http://www.excel-jeanie-html.de/index.php?f=1


Have a great day,
Stan