Question

我有一个包含很长名称列表的数据库，以及与这些名称相关联的唯一值。我想要做的是为每个人创建一个工作表，然后将他们的数据只复制到他们工作表中的指定范围，然后继续下一个人，将他们的数据复制到他们的工作表等。

Here是一个示例工作表的链接（在Google文档表单中，请注意 - 我实际上使用的是Excel 2010，而不是Google文档）。

我已经能够通过在名为“Employee”的新工作表中使用以下代码来创建所有工作表。我在这张表上做的就是删除重复的名称值，这样我就可以得到工作表的所有名称列表。

非常感谢任何帮助。提前谢谢。

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

裸骨方法 - 可以针对更好的性能进行优化，但它可以完成这项工作。

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

从Excel数据库中提取数据

1 个答案: