如何为列中的每个唯一值创建新工作簿，并复制相应的行数据加模板

Question

我正在尝试自动创建报告。我有一个名称位于a列的工作簿。我正在尝试编写一个宏，该宏扫描a列，对于a列中的每个唯一名称，我希望该宏创建一个新工作簿，并将与该名称匹配的每一行数据复制到新工作簿的第二页。我还试图使用一个模板作为第一页。每个名称的模板都是相同的，因此不是唯一的。基本上，宏将扫描A列，并为每个唯一的名称创建一个工作簿，其中包含第二页上的相应数据，第一页将是一个模板，其中包含引用第二页的公式，其中的数据是复制的。

我有一个宏，它扫描列中的每个唯一名称，只复制该值的偏移量，并使用模板，但它不会将对应数据的每一行都复制到第二个工作表。这是一个为其他东西编程的宏，但它与我现在尝试的非常相似。忽略在代码中选择模板的使用，因为此宏每次都将使用相同的模板。这段代码与我试图做的非常相似，但可能不是最好的基线，idk？

Sub CreateBrokersFiles()

Dim brokerName As Range, namesTable As Range
Dim i As Integer
Dim alreadyExists As Boolean, passedMargin As Boolean
Dim templateName As String, filePath As String, fileName As String

On Error GoTo ErrorHandler

'// This is the range where the names are found in the Summary sheet.
Set namesTable = Worksheets("Summary").Range("B6", Worksheets("Summary").Range("B6").End(xlDown))

filePath = "C:\Users\Connor.Osborne\Desktop\code output to"
'// Insert file path with no final backslash. Just as it comes when you copy from Windows.

For Each brokerName In namesTable
    alreadyExists = False
    passedMargin = False
    fileName = filePath & "\" & brokerName.Value & ".xlsx"

    '// this checks if the file already exists and if so, DOES NOT overwrite it.
    If Len(Dir(fileName)) > 0 Then alreadyExists = True

    If Not alreadyExists Then

        '// this checks if passed margin is more than zero, and assigns the correct template.
        '// Make sure the template sheets have the EXACT same names as the values
        '// in the Title column, followed by a space and either Template or PM Template.

        If brokerName.Offset(0, 13).Value > 0 Then passedMargin = True
        If passedMargin Then
            templateName = brokerName.Offset(0, 2).Value & " PM Template"
        Else
            templateName = brokerName.Offset(0, 2).Value & " Template"
        End If

        Worksheets(templateName).Visible = xlSheetVisible
        '// Using the .Copy method, Excel automatically opens and activates a new workbook.
        Worksheets(templateName).Copy

        With ActiveWorkbook.Sheets(1)
            .Name = brokerName.Value
            '// This is where to find the correct values to copy, and where to copy them.
            brokerName.Copy .Range("J4")
            brokerName.Offset(0, 1).Copy .Range("J5")
            brokerName.Offset(0, 2).Copy .Range("J6")
            brokerName.Offset(0, 3).Copy .Range("J7")
            brokerName.Offset(0, 4).Copy .Range("J8")
            brokerName.Offset(0, 5).Copy .Range("J9")
            brokerName.Offset(0, 6).Copy .Range("J10")
            brokerName.Offset(0, 7).Copy .Range("J11")
            brokerName.Offset(0, 8).Copy .Range("J12")
            brokerName.Offset(0, 9).Copy .Range("J13")
            brokerName.Offset(0, 10).Copy .Range("J14")
            brokerName.Offset(0, 11).Copy .Range("J16")
            brokerName.Offset(0, 12).Copy .Range("J17")
            brokerName.Offset(0, 13).Copy .Range("J18")
            brokerName.Offset(0, 14).Copy .Range("J19")
            brokerName.Offset(0, 15).Copy .Range("J21")
            brokerName.Offset(0, 16).Copy .Range("J22")
            brokerName.Offset(0, 13).Copy .Range("J23")
            brokerName.Offset(0, 17).Copy .Range("J24")
            brokerName.Offset(0, 18).Copy .Range("J25")
            brokerName.Offset(0, 19).Copy .Range("J27")

        End With

        ActiveWorkbook.SaveAs (fileName)
        ActiveWorkbook.Close

    End If
Next brokerName
Exit Sub

 ErrorHandler:
    MsgBox ("Something went wrong." & vbNewLine & _
    "Probably your sheet template names do not match the values in the Summary table." & vbNewLine & _
    "Please recheck the names!"), vbCritical
 End Sub

基本上，宏将扫描列A，并为每个唯一的名称创建一个工作簿，其中第一页上有一个模板，该名称对应的数据行复制到第二页。工作表1将是一个模板，其中包含引用工作表2的公式，其中复制了数据。

Answer 1

看起来您刚刚找到了一个代码片段并询问如何使其适用于您的应用程序。该代码对我来说对您的应用程序没有意义，但我不专业。一般来说，它应该研究您的问题并就您使用代码时遇到的特定问题提出问题。问题应遵循https://stackoverflow.com/help/minimal-reproducible-example.

但是，我正在学习VBA，想试试我的手。尽管如此，这一准则绝不是完美的。

我首先将每个问题分解为单独的问题，您需要这样做，然后分别在谷歌上搜索它们。我通常会一直这样做，直到它起作用，然后再研究性能/改进代码等。我99%确信这符合你帖子的所有要求，但我能感觉到人们在阅读代码时都在畏缩。我希望您不要在大型数据集上运行此功能，或者经常运行此功能，因为这肯定不是处理问题的最佳方式。

试一试，我的示例数据如下所示：

A   1
B   2
C   3
A   4
B   5
C   6
A   7

代码：

Sub GetUniqueAndCount()

    Set wb = ActiveWorkbook
    Set ws = ActiveSheet

    Dim d As Object, c As Range, k, tmp As String

    Set c = Range("A1:A255")
    Set d = CreateObject("scripting.dictionary")
    For Each c In c
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c

    For Each k In d.keys
        'Debug.Print k, d(k)
        'MsgBox k     ' Array Name
        'MsgBox d(k)        ' Size of Array
        'Do Stuff with each Array Here
            Set c = Range("A1:A255")
            For Each c In c
                If IsEmpty(c.Value) = False Then
                If c.Value = k Then
                'MsgBox "Match in Cell" & c.Address
                'Problem2
                    If Dir(ThisWorkbook.Path & "\" & k & ".xlsx") = "" Then
                        'MsgBox "Saving New File!" ' Use for Debugging
                        Set NewBook = Workbooks.Add
                        With NewBook
                            Sheets.Add.Name = "Sheet2"
                            c.EntireRow.Copy .Sheets("Sheet2").Rows("1")
                            .Title = k
                            .Subject = k
                            .SaveAs Filename:=k & ".xlsx"
                        End With
                        Workbooks(k & ".xlsx").Close
                    Else
                        'MsgBox "File Already Exists!" ' Use for Debugging
                        c.EntireRow.Copy
                        Workbooks.Open (k & ".xlsx")
                        lRow = ActiveWorkbook.Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
                        c.EntireRow.Copy Workbooks(k & ".xlsx").Sheets("Sheet2").Rows(lRow)
                        Workbooks(k & ".xlsx").Close SaveChanges:=True
                    End If
                End If
                End If
            Next c
    Next k

End Sub

一些来源：

从Excel将唯一值填充到VBA数组中

VBA通过单击按钮创建新工作簿

当文件已经存在时，如何保存Excel工作簿？

打开和保存新工作簿-VBA