Excel 基于基于主键的行中的唯一值创建图纸

我正试图根据以下规则，基于给定数据（随附的样本表）填充多张表：

客户代码是主键，每一页都应包含每个唯一的客户代码

新的工作表应命名为“CustomerCode_Leads”

每个工作表都应该有相同的标题

我从一个逻辑开始，构建了一个代码，但我缺乏如何逐行读取客户代码数据、复制具有相同客户代码的行并根据唯一客户代码将其粘贴到工作表中的知识

目前编写的代码：

Sub Test()
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Data")
    ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
    
    Selection.AutoFilter
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.EntireRow.Select
    Selection.Delete Shift:=xlUp
    Application.Goto Reference:="R2C2"
    ActiveCell.EntireColumn.Select
    
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$A$5000").RemoveDuplicates Columns:=1, Header:=xlYes
    
    Dim CurSheet As Worksheet
    Dim Source As Range
    Dim c As Range

    Set CurSheet = ActiveSheet
    Set Source = Selection.Cells
    Application.ScreenUpdating = False

    For Each c In Source
        sName = Trim(c.Text)
        If Len(sName) > 0 Then
                Worksheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = sName + "_Leads"
        End If
    Next c
    
End Sub

所需输出：

是否有人建议如何逐行读取数据，并将其粘贴到名为“CustomerCode_Lead”的新工作表中，其中“CustomerCode”是数据表中具有某些值的变量

我遵循的算法是：

复制数据表并将其粘贴到新工作表中

根据客户代码按升序对数据进行排序（它将把所有类似的客户代码放在一起，便于逐行读取）

逐行读取数据，复制整行并粘贴到新的工作表中，直到客户代码保持不变，一旦不同的代码到达下一行，它将创建一个名为“CustomerCode_Leads”的新工作表

读取数据，直到“数据”表中的数据结束

我绝对会提前感谢您为我提供的社区帮助。：）

这就是您所需要的：

它可能如下所示：

Option Explicit

Public Sub SplitDataByCustomerIntoSheets()
    Dim wsData As Worksheet
    Set wsData = ThisWorkbook.Worksheets("Data")
    
    Dim LastRow As Long
    LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    
    'creat unique list of customer codes (https://stackoverflow.com/questions/36044556/quicker-way-to-get-all-unique-values-of-a-column-in-vba)
    Dim UniqueValues() As Variant
    UniqueValues = wsData.Range("A2:A" & LastRow).Value
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim iRow As Long
    For iRow = 1 To UBound(UniqueValues)
        dict(UniqueValues(iRow, 1)) = Empty
    Next
    
    UniqueValues = WorksheetFunction.Transpose(dict.Keys())
    
    
    'check if filter was already set
    If wsData.FilterMode = False Then
        wsData.Range("A1").AutoFilter
    Else
        wsData.ShowAllData
    End If
    
    Dim CustomerID As Variant
    For Each CustomerID In UniqueValues 'loop through all customer IDs
        With wsData.Range("A1:B" & LastRow) 'make sure to adjust B to the last column of your data
            .AutoFilter Field:=1, Criteria1:=CustomerID 'filter by customer ID
            
            'create a new sheet as last sheet and name it by customer ID
            Dim NewSheet As Worksheet
            Set NewSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            NewSheet.Name = CustomerID & "_Leads"
            
            'copy visible cells of filtered data to new sheet
            .SpecialCells(xlCellTypeVisible).Copy NewSheet.Range("A1")
        End With
    Next CustomerID
End Sub

数据表：

它将为每个客户ID创建一张表，如下所示：

---

请不要发布指向文件的链接。如果你想给出示例数据，请确保将其包含在问题中。如果你想展示一些东西，包括屏幕截图。理解你的问题所需要的一切都需要在问题本身。链接迟早会消失，问题也就没用了。另见我强烈建议你阅读并将这种方法应用到你的代码中。你也应该问一个更精确的问题。需求列表不是一个真正的问题（）。你到底在哪里被卡住或出错？出了什么问题？是什么阻止了你自己做这件事？你的困难在哪里？你试图达到什么目的？@Pᴇʜ：我正在尽可能地更新这个问题。感谢到目前为止的宝贵反馈：）这有助于回答您的问题吗。这个想法将是第一个将你的客户代码列。然后为每个唯一的代码过滤工作表

数据

，并将其复制到新工作表。试一试，这应该行得通。实际上，这正是您需要做的：获取一个唯一客户ID的列表，遍历该ID列表，为数据表中的每个ID筛选。然后将文件数据复制到一个新的工作表中，并使用ID命名。这两个链接具有您所需的所有内容。感谢@Peh，我检查了逻辑仅适用于您创建的样本数据集，但它正在创建300多页（也有重复页），例如，对于客户ID（如我的样本集中所示），它正在为10404860创建3张工作表，知道它是如何不选择唯一值的吗？您是否将此

UniqueValues=wsData.Range（“A2:A”&LastRow）.value

列调整为您的客户ID列？您是否将

.AutoFilter field:=1，Criteria1:=CustomerID

中的字段号调整为您的客户ID的列号？是的，我调整了，但它没有按应有的方式响应，让我重新运行它。将此答案标记为现在正确！：）它没有填充数据，例如，它创建了工作表1，但值为空。@desmond.carros实际上，如果没有更多详细信息，很难判断出哪里出了问题。如果你仍然陷入困境，可能会问一个新问题，说明你到底做了什么如果你问了一个新问题，确保你的截图包含字母a，B…