VBA - Copy data with formatting to dynamic sheets based on name

[NathanA]

I have one 'overview' tab with data used to create a timeline for each row for many people. The macro should copy data from that sheet into new sheets based on the names in column C - i.e. a dynamic set up. However, the macro I used copy rows but the formatting (a timeline bar) in each row didn't copy over correctly.

How can I copy over the data that's in the 'overview' tab into new sheets with one name per sheet? There is formatting above row 7, and this is also necessary to copy over. The actual data with the names start in row 7 of the 'overview' tab.

Sub RunIndividualProjects()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    Set Source = ActiveWorkbook.Worksheets("Timeline overview")
    Set Target = ActiveWorkbook.Worksheets("Name 1")

    J = 1 
    For Each c In Source.Range("E1:E1000")   ' Do 1000 rows
        If c = "Name 1" Then
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
End Sub

 

[JLGWhiz]

this is untested, but maybe it will get you on the right track.

Sub RunIndividualProjects()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet
    Set Source = ActiveWorkbook.Worksheets("Timeline overview")
    For Each c In Source.Range("E1:E1000")   ' Do 1000 rows
    On Error Resume Next
        Set Target = ActiveWorkbook.Worksheets(c.Value)
            If Err.Number > 0 Then 'new sheets needed for added names
                Sheets.Add After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = c.Value
                Source.Range("1:6").EntireRow.Copy
                Sheets(Sheets.Count).Range("1:6").EntireRow.PasteSpecial xlPasteFormats
                Source.Rows(c.Row).Copy
                Sheets(Sheets.Count).Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
                Sheets(Sheets.Count).Cells(Rows.Count, 1).End(xlUp).EntireRow.PasteSpecial xlPasteFormats
            Else 'existing sheets for old names
                Source.Rows(c.Row).Copy
                Target.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
                Target.Cells(Rows.Count, 1).End(xlUp).EndtireRow.PasteFormats
            End If
    Next c
End Sub

 

[NathanA]

Thanks for looking at this - the code does generate new sheets, however it generates 1000, and it's not based on the amount of names.

Is it possible to only have one sheet per name - i.e. one sheet named 'Joe' could have more than one row of data, based on what was below row 7 in the overview sheet.

 

[JLGWhiz]

Thanks for looking at this - the code does generate new sheets, however it generates 1000, and it's not based on the amount of names.

Is it possible to only have one sheet per name - i.e. one sheet named 'Joe' could have more than one row of data, based on what was below row 7 in the overview sheet.

This version should only produce new sheets for the first occurrence of a name in column E. Any subsequent occurence of the same name should just copy and paste to the existing sheet. Might need some tweaking, but give it a try.

Sub RunIndividualProjects()
    Dim c As Range
    Dim Source As Worksheet
    Dim Target As Worksheet
    Set Source = ActiveWorkbook.Worksheets("Timeline overview")
    For Each c In Source.Range("E1", Source.Cells(Rows.Count, 5).End(xlUp))    ' Dynamic range
    On Error Resume Next
        Set Target = ActiveWorkbook.Worksheets(c.Value)
            If Err.Number > 0 Then 'new sheets needed for added names
                Sheets.Add After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = c.Value
                Source.Range("1:6").EntireRow.Copy
                Sheets(Sheets.Count).Range("1:6").EntireRow.PasteSpecial xlPasteFormats
                Source.Rows(c.Row).Copy
                Sheets(Sheets.Count).Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
                Sheets(Sheets.Count).Cells(Rows.Count, 1).End(xlUp).EntireRow.PasteSpecial xlPasteFormats
            Else 'existing sheets for old names
                Source.Rows(c.Row).Copy
                Target.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteValues
                Target.Cells(Rows.Count, 1).End(xlUp).EndtireRow.PasteFormats
            End If
            On Error GoTo 0
    Next c
End Sub

 

[NathanA]

Thanks. I took the code and set up several stages: deleted existing user sheets, retrieved unique list of users, copied the master sheet to create individuals sheets, and from that deleted the unwanted rows.