循环遍历列表，并根据该列表创建新的工作表

Question

我目前正在做一个项目。我在名为“Master”的工作表的 A 列中有一个职位列表。我需要循环遍历该列表并检查它们是否作为工作表存在。如果不存在，它应该创建一个包含列表中内容的工作表。不过，我可以完成这一部分：

我有另一张名为“数据”的工作表。其中包含员工的数据，例如他们的全名、入职日期、职位和联系电话。我需要按他们的职位对他们进行分类，并将其粘贴到通过名为“主表”的工作表上的列表创建的各自工作表上。

这是我目前所拥有的：

Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range
Dim ans As Long

Sheet4.Select
Range("M2").Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Set MyRange = Selection
For Each MyCell In MyRange
    If Len(MyCell.Text) > 0 Then
        'Check if sheet exists
        If Not SheetExists(MyCell.Value) Then
            Sheets.Add after:=Sheets(Sheets.Count) 'creates a new worksheet
            Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
            'Worksheets("Master").Cells.Copy ActiveSheet.Range("A1")

            'run report codes here

            Sheet3.Select
            Range("A:T").AutoFilter
            Range("D1").Select
            Range("D1").AutoFilter Field:=4, Criteria1:=MyCell.Value, Operator:=xlFilterValues

            Range("A1:T1").Select
            Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
            Range("A1:T" & Lastrow).Select
            Selection.Copy

            Range("AH2").Select
            ActiveCell.PasteSpecial xlPasteValues

        Else

            'insert code for updating of reports here
        End If
    End If

Next MyCell
End Sub

Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet

 If wb Is Nothing Then Set wb = ThisWorkbook
 On Error Resume Next
 Set sht = wb.Sheets(shtName)
 On Error GoTo 0
 SheetExists = Not sht Is Nothing
 End Function

例如：我需要按职位过滤数据。例如，我的循环创建了一个名为 Waiters 的工作表。数据表将被过滤，所有职位为服务员的员工将被复制到 Waiters 工作表。之后，它将继续循环遍历 Master 工作表上的列表并创建另一个工作表，例如 Cooks。然后再次过滤数据表，所有职位为厨师的员工将被复制到 Cooks 工作表。它将继续循环，直到 Master 工作表上我的列表上的最后一条条目。

请帮忙

Answer 1

示例工作簿

因此，我创建了一个与您的类似但不完全相同的工作簿：

该表的主要特点是：

• 职位列：工作表名称以此为依据。
• 有一列用于指示数据是否已经被复制，因为您说过不想从工作Master表中删除这些行。
• 其余数据可以是任何内容。我只是用垃圾数据填充了我的数据。

我的宏

Public Sub copy_new_people()

Dim job_name As String

Dim insert_index As Integer
Dim employee As String
Dim employee_index As Integer


For Row = 2 To ThisWorkbook.Sheets("Master").Range("A1").End(xlDown).Row
    If ThisWorkbook.Sheets("Master").Range("D" & Row).Value <> "y" Then 'don't re-copy items
        'does worksheet exist?
        job_name = ThisWorkbook.Sheets("Master").Range("A" & Row).Value
        If WorksheetExists(job_name, ThisWorkbook) = False Then
            'create worksheet
            ThisWorkbook.Sheets.Add.Name = job_name
            'add headers
            ThisWorkbook.Sheets(job_name).Range("A1").Value = "Job Title"
            ThisWorkbook.Sheets(job_name).Range("B1").Value = "Header1"
            ThisWorkbook.Sheets(job_name).Range("C1").Value = "Header2"
        End If

        'now add data
        'get next available index
        If ThisWorkbook.Sheets(job_name).Range("A2").Value = "" Then
            insert_index = 2
        Else
            insert_index = ThisWorkbook.Sheets(job_name).Range("A2").End(xlDown).Row + 1
        End If


        'get employee index for employee data
        employee = ThisWorkbook.Sheets("Master").Range("B" & Row).Value

        For row2 = 2 To ThisWorkbook.Sheets("Data").Range("A1").End(xlDown).Row
            If ThisWorkbook.Sheets("Data").Range("A" & row2).Value = employee Then
                employee_index = row2
                Exit For
            End If
        Next

        ThisWorkbook.Sheets(job_name).Range("A" & insert_index).Value = ThisWorkbook.Sheets("Master").Range("A" & Row).Value
        ThisWorkbook.Sheets(job_name).Range("B" & insert_index).Value = ThisWorkbook.Sheets("Data").Range("B" & employee_index).Value
        ThisWorkbook.Sheets(job_name).Range("C" & insert_index).Value = ThisWorkbook.Sheets("Master").Range("C" & employee_index).Value


        'lastly mark on Master sheet that it has been copied
        ThisWorkbook.Sheets(job_name).Range("D" & insert_index).Value = "y"

    End If
Next


End Sub


Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

代码要点

• 我编写了一个单独的函数，用于在工作簿包含指定名称的工作表时返回 true / false。这使得代码更加可重用且更简洁。

• 主循环只是从工作表顶部开始Master，然后到底部。它只查看那些列为Copied空白（尚未添加）的行

• 如果工作表尚不存在则它会创建它。

• 一旦代码到达该add data部分，任何工作表都必须已经存在，因为它要么刚刚创建，要么之前找到。

• insert_index用于查找目标工作表的下一行

• 之后的下一部分insert_index是复制所有数据的地方。根据需要调整列

• 最后一项是关键，将一些内容添加回原始Copied列以表明复制有效。

• 还请注意，我从不使用Select命令，而是直接通过行和列引用项目。这是一种更可靠的方法。