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列，并为每个唯一名称创建一个工作簿，该工作簿的第一页上有一个模板，并将该名称的相应数据行复制到第二页上。第一页将是一个模板，该模板具有引用第二页的公式，在第二页中复制了数据。

Answer 1

似乎您刚刚找到一个代码段，并询问如何使其适合您的应用程序。对于您的应用程序，该代码对我而言没有意义，但我不是专业人士。通常，期望对您的问题进行研究，并就您的代码遇到的特定问题提出问题。问题应遵循https://stackoverflow.com/help/minimal-reproducible-example。

但是，我正在学习VBA，并想尝试一下。话虽如此，这段代码绝不是完美的。

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

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

代码：

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

某些来源：

Populate unique values into a VBA array from Excel

VBA Create a new workbook with a button click

How to save an Excel Workbook when the file already exists?

Opening and Saving new Workbooks - VBA

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

1 个答案: