Extracting Data from Excel Database

Question

I've got a database with a long list of names, and unique values associated with the names. What I want to do is create one worksheet for each individual, and then copy only their data to a specified range in their worksheet, then proceed to the next individual, copy their data to their worksheet etc.

Here is a link to an example worksheet (in google docs form, note - I am actually using Excel 2010, not google docs).

I've been able to create all the worksheets through using the following code in a new sheet I called "Employee". All I did to this sheet was remove the duplicate name values so I could have a list of all the names for the worksheets.

Any help is much appreciated. Thanks in advance.

Sub CreateSheetsFromAList()
Dim nameSource      As String 'sheet name where to read names
Dim nameColumn      As String 'column where the names are located
Dim nameStartRow    As Long   'row from where name starts

Dim nameEndRow      As Long   'row where name ends
Dim employeeName    As String 'employee name

Dim newSheet        As Worksheet

nameSource = "Employee"
nameColumn = "A"
nameStartRow = 1


'find the last cell in use
nameEndRow = Sheets(nameSource).Cells(Rows.Count, nameColumn).End(xlUp).Row

'loop till last row
Do While (nameStartRow <= nameEndRow)
    'get the name
    employeeName = Sheets(nameSource).Cells(nameStartRow, nameColumn)

    'remove any white space
    employeeName = Trim(employeeName)

    ' if name is not equal to ""
    If (employeeName <> vbNullString) Then

        On Error Resume Next 'do not throw error
        Err.Clear 'clear any existing error

        'if sheet name is not present this will cause error that we are going to leverage
        Sheets(employeeName).Name = employeeName

        If (Err.Number > 0) Then
            'sheet was not there, so it create error, so we can create this sheet
            Err.Clear
            On Error GoTo -1 'disable exception so to reuse in loop

            'add new sheet
            Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))

            'rename sheet
            newSheet.Name = employeeName


            'paste training material
            Sheets(employeeName).Cells(1, "A").PasteSpecial
            Application.CutCopyMode = False
        End If
    End If
    nameStartRow = nameStartRow + 1 'increment row
Loop
End Sub

Answer 1

Bare bones approach - could be optimized for better performance, but it will do the job.

Sub SplitToSheets()

Dim c As Range, ws As Worksheet, rngNames

    With ThisWorkbook.Sheets("EmployeeData")
        Set rngNames = .Range(.Range("A1"), .Cells(Rows.Count, 1).End(xlUp))
    End With

    For Each c In rngNames.Cells
        Set ws = GetSheet(ThisWorkbook, c.Value)
        c.EntireRow.Copy ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    Next c

End Sub


Function GetSheet(wb As Workbook, wsName As String, _
         Optional CreateIfMissing As Boolean = True) As Worksheet

    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Sheets(wsName)
    On Error GoTo 0

    If ws Is Nothing And CreateIfMissing Then
        Set ws = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
        ws.Name = wsName
    End If

    Set GetSheet = ws
End Function