Create named worksheets

[bobkap]

I have come to the point in my macro where I have many rows of unsorted data. Each row has a person's name. I need to create a worksheet for each person, name the worksheet their name and copy JUST their data to the sheet with their name. Data looks something like this:

Date Name1 Location1 [more columns of data]
Date2 Name2 Location2 [more columns of data]
Date Name1 Location1 [more columns of data]
Date Name1 Location1 [more columns of data]
Date3 Name2 Location3 [more columns of data]
Date Name3 Location4 [more columns of data]
etc etc

Any help our suggestions of how to handle with VBA would be greatly appreciated.

 

[mikerickson]

This should work. (Error handling to be added)

Sub test()
    Dim oneCell As Range
    Dim DataRange As Range
    Dim i As Long
    With Sheets("Sheet1").Range("A:A")
        Set DataRange = Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
    End With
    
    For Each oneCell In DataRange
        With ThisWorkbook.Worksheets.Add
            .Rows(1).Value = oneCell.EntireRow.Value
            .Name = CStr(oneCell.Value)
        End With
    Next oneCell
End Sub

 

[mikerickson]

I think the above missed some things. This is better.

Sub test2()
    Dim oneCell As Range
    Dim dataRange As Range
    Dim i As Long, sheetName As String
    With Sheets("Sheet1").Range("A:A")
        Set dataRange = Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
    End With
    
    For Each oneCell In dataRange
        sheetName = CStr(oneCell.Value)
        On Error Resume Next
        If LCase(ThisWorkbook.Sheets(sheetName).Name) <> LCase(sheetName) Then
            On Error GoTo 0
            With ThisWorkbook.Worksheets.Add
                .Rows(1).Value = oneCell.EntireRow.Value
                .Name = sheetName
            End With
        Else
            On Error GoTo 0
            ThisWorkbook.Sheets(sheetName).Range("A65536").End(xlUp).Offset(1, 0).EntireRow.Value = oneCell.EntireRow.Value
        End If
    Next oneCell
End Sub

 

[bobkap]

Awesome. Mega thanks! JUST when I think I know what I'm doing in VBA I get reminded that I have SOOO much more to learn.

Not sure if you got my reply to your message. Sorry if this is a repeat.

Thanks VERY much for your help! It works beautifully. Someday, I hope to be better educated in VBA so I can understand how to do things like this.

If I'm not pushing my luck, may I ask for your help to figure out the following please?:
1. My headers are in row 1 of course. How do I avoid creating a new sheet with just these headers in it?
2. How do I have the first 13 of these headers show up in row 1 of each of these new sheets?

Thanks again!

 

[mikerickson]

1) Start the definition of dataRange on row 2

Set dataRange = Range(.Cells(1, [COLOR="#FF0000"]2[/COLOR]), .Cells(Rows.Count, 1).End(xlUp))

2) Not sure if this is what you mean, but if you want A1:M1 of each of the new sheets to be the same as A1:M1 of Sheet1:

Sub test3()
    Dim oneCell As Range
    Dim dataRange As Range
    Dim i As Long, sheetName As String
    Dim arrHeaders as Variant
    With Sheets("Sheet1").Range("A:A")
        Set dataRange = Range(.Cells(1, [COLOR="#FF0000"]2[/COLOR]), .Cells(Rows.Count, 1).End(xlUp))
        [COLOR="#FF0000"]arrHeaders = .Resize(1, 13).Value[/COLOR]
    End With
    
    For Each oneCell In dataRange
        sheetName = CStr(oneCell.Value)
        On Error Resume Next
        If LCase(ThisWorkbook.Sheets(sheetName).Name) <> LCase(sheetName) Then
            On Error GoTo 0
            With ThisWorkbook.Worksheets.Add
                [COLOR="#FF0000"].Cells(1,1).Resize(1, 13).Value = arrHeaders[/COLOR]
                .Rows([COLOR="#FF0000"]2[/COLOR]).Value = oneCell.EntireRow.Value
                .Name = sheetName
            End With
        Else
            On Error GoTo 0
            ThisWorkbook.Sheets(sheetName).Range("A65536").End(xlUp).Offset(1, 0).EntireRow.Value = oneCell.EntireRow.Value
        End If
    Next oneCell
End Sub

 

[bobkap]

Thanks again! Everything works perfectly now except it still creates a worksheet using the name of my header cell(1,1) contents.

 

[mikerickson]

Try this change

Set dataRange = Range(.Cells([COLOR="#FF0000"]2, 1[/COLOR]), .Cells(Rows.Count, 1).End(xlUp))