How to create a new workbook for each unique value in column and copy corresponding row data plus template

Question

I am trying to automate the creation of a report. I have a workbook with names in column A. I am trying to program a macro that scans through column A, and for each unique name in column A, i would like the macro to create a new workbook and copy each corresponding row of data that matches that name to sheet two of the new workbook. I am also attempting to use a template as sheet one. The template will be the same for every name, so not unique. essentially the macro would scan Column A, and for each unique name it creates a workbook with the corresponding data on sheet two, and sheet one will be a template that has formulas that reference sheet two, where the data was copied.

I have a macro that scans for each unique name in a column and copies just offset of that value and uses templates, however it doesn't copy every single row of corresponding data to a second sheet. It is a macro that was programmed for something else, however it is very similar to what i am attempting to do now. Ignore the use of selecting a template in the code as this macro will use the same template every time. This code is very similar to what i'm attempting to do, but is maybe not the best baseline to work off of, 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

Essentially the macro would scan Column A, and for each unique name, it creates a workbook with a template on sheet one and the corresponding rows of data for that name copied on to sheet two. Sheet one will be a template that has formulas that reference sheet two, where the data was copied.

Answer 1

It seems like you just found a code snippet and asked how to make it work for your application. The code doesn't make sense to me for your application, but I'm not pro. Generally it is expected to research your problem and ask questions about specific issues your having with your code. Questions should follow the https://stackoverflow.com/help/minimal-reproducible-example.

But, I am learning VBA and wanted to try my hand. That being said, this code is by no means perfect.

I started by breaking down each issue into separate issues as you will need to do and google them individually. I generally do this till it works then look into performance/improving code etc. I am 99% sure this meets all requirements of your post, but I can just feel people cringing while reading the code. I hope your not running this on a large data-set or often as it is not the best way of approaching things for sure.

Give this a try, my sample data looked like this:

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

Code:

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

Some Sources:

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