How to create a new Workbook for each unique value in a column?

Question

I need to run a foreach statement for each unique value in column J. For each unique name, I want to create a new Excel Workbook copy all the rows for the specific name and finally save the workbook with the same unique value.

Sub test()
Range("A1:J17").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Application.CutCopyMode = False
Range("D1").Select
Selection.Copy
ChDir "c:\test"
ActiveWorkbook.SaveAs Filename:= _
    "c:\test\test.xlsx", _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

Take a look at this link: https://stackoverflow.com/questions/36044556/quicker-way-to-get-all-unique-values-of-a-column-in-vba about getting unique values in an array. You can then execute activites utilizing the created array. — Cyril, Sep 22 '17 at 16:01

barvobot · Accepted Answer · 2017-09-26T12:33:00.837

I'm sure someone smarter than me can tell you how to ReDim the arrays or something but this should work. I set the size to 1,000 max by default but set it higher if there are more rows to check. This also assumes that column J is the last column with data that needs to be copied to the new workbook: if this isn't the case, change ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy to ws.Range(ws.Cells(y, 1), ws.Cells(y, WHATEVER_COLUMN)).Copy

Option Explicit

Sub ExportByName()
Dim unique(1000) As String
Dim wb(1000) As Workbook
Dim ws As Worksheet
Dim x As Long, y As Long, ct As Long, uCol As Long

On Error GoTo ErrHandler

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Your main worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")

'Column J
uCol = 10

ct = 0

'get a unique list of users
For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
        unique(ct) = ActiveSheet.Cells(x, uCol).Text
        ct = ct + 1
    End If
Next x

'loop through the unique list
For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row - 1

    If unique(x) <> "" Then
        'add workbook
        Set wb(x) = Workbooks.Add

        'copy header row
        ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)

        'loop to find matching items in ws and copy over
        For y = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
            If ws.Cells(y, uCol) = unique(x) Then

                'copy full formula over    
                'ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1)

                'to copy and paste values
                ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
                wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial (xlPasteValues)

            End If
        Next y

        'autofit
        wb(x).Sheets(1).Columns.AutoFit

        'save when done
        wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x) & " " & Format(Now(), "mm-dd-yy")
        'wb(x).Close SaveChanges:=True

    Else
        'once reaching blank parts of the array, quit loop
        Exit For
    End If

Next x

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
End Function

Hey J, I'm having a problem with the vlookup formulas after copying over to the new workbook, the values appear as #N/A. How can I do a paste special with just the values and the same source formating? — Tony Batista, Sep 25 '17 at 20:20
@Tony I edited my answer above to include both just regular copying and copying just values. Essentially you just do the copy on one line, then do `.PasteSpecial (xlPasteValues)` with the target range. — barvobot, Sep 26 '17 at 12:34
I made an addition to copy the source formatting with the values, see below. — Tony Batista, Sep 26 '17 at 14:24
ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy With wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1) .PasteSpecial (xlPasteValuesAndNumberFormats) .PasteSpecial (xlPasteFormats) End With — Tony Batista, Sep 26 '17 at 14:24

How to create a new Workbook for each unique value in a column?

1 Answers1

Linked