How to break out data into separate files?

Question

I'm trying to break out an Excel data table into unique files based on a project name in column A.
For example, In the table below I need to break out three separate files (Project A, Project B, and Project C).

I have VBA code to separate the files into separate tabs, but not separate files.

Sub Break_Out()
    
    Const col = "A"
    Const header_row = 1
    Const starting_row = 2
    
    Dim source_sheet As Worksheet
    Dim destination_sheet As Worksheet
    Dim source_row As Long
    Dim last_row As Long
    Dim destination_row As Long
    Dim Project As String
    
    Set source_sheet = ActiveSheet
    last_row = source_sheet.Cells(source_sheet.Rows.Count, col).End(xlUp).Row
    For source_row = starting_row To last_row
        Project = source_sheet.Cells(source_row, col).Value
        Set destination_sheet = Nothing
        On Error Resume Next
    
        Set destination_sheet = Worksheets(Project)
        On Error GoTo 0
    
        If destination_sheet Is Nothing Then
            Set destination_sheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            destination_sheet.Name = Project
            source_sheet.Rows(header_row).Copy Destination:=destination_sheet.Rows(header_row)
    
        End If
        destination_row = destination_sheet.Cells(destination_sheet.Rows.Count, col).End(xlUp).Row + 1
        source_sheet.Rows(source_row).Copy Destination:=destination_sheet.Rows(destination_row)
    
    Next source_row
    
End Sub

Answer 1

Dictionary to Collect Workbook Names

• This code basically only implements a dictionary object into the initial code, to collect the worksheet names (values of the Project variable) and after the code has created the worksheets, moves them to files getting saved as Project A.xlsx, Project B.xlsx and Project C.xlsx in a specified folder, in this case in "F:\Test\2020\64862938\".

The Code

Option Explicit

Sub Break_Out()

    Const fPath As String = "F:\Test\2020\64862938\"
    Const sCol As String = "A"
    Const dCol As String = "A"
    Const hRow As Long = 1
    Const fRow As Long = 2
    
    Dim wb As Workbook
    Dim src As Worksheet
    Dim dst As Worksheet
    Dim dict As Object ' ***
    Dim Key As Variant ' ***
    Dim i As Long
    Dim lRow As Long
    Dim dRow As Long
    Dim Project As String
    
    Set wb = ThisWorkbook ' The workbook containing this code.
    Set src = wb.ActiveSheet ' Set src = wb.worksheets("Sheet1") is better.
    lRow = src.Cells(src.Rows.Count, sCol).End(xlUp).Row
    
    Set dict = CreateObject("Scripting.Dictionary") ' ***
    
    Application.ScreenUpdating = False
    
    For i = fRow To lRow
        
        Project = "Project " & src.Cells(i, sCol).Value
        Set dst = Nothing
        On Error Resume Next
        Set dst = wb.Worksheets(Project)
        On Error GoTo 0
        
        If dst Is Nothing Then
            Set dst = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            dst.Name = Project
            dict(Project) = Empty ' ***
            src.Rows(hRow).Copy Destination:=dst.Rows(hRow)
        End If
        dRow = dst.Cells(dst.Rows.Count, dCol).End(xlUp).Row + 1
        src.Rows(i).Copy Destination:=dst.Rows(dRow)
    
    Next i
    
    ' Move worksheets to files.
    For Each Key In dict.Keys ' ***
        wb.Worksheets(Key).Move ' ***
        With ActiveWorkbook
            ' This will overwrite the previous versions.
            Application.DisplayAlerts = False
            .SaveAs Filename:=fPath & Key, _
                    FileFormat:=xlOpenXMLWorkbook ' .xlsx ' ***
            Application.DisplayAlerts = True
            .Close SaveChanges:=False
        End With
    Next Key ' ***
    
    wb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Worksheets created.", vbInformation, "Success"
    
End Sub

Answer 2

Here's one way, using a Dictionary to track the workbooks created during the run

Sub Break_Out()

    Const col = "A"
    Const header_row = 1
    Const starting_row = 2
    
    Dim source_sheet As Worksheet
    Dim source_row As Long
    Dim last_row As Long
    Dim Project As String
    Dim dict As Object
    
    Set dict = CreateObject("scripting.dictionary")
    Set source_sheet = ActiveSheet
    last_row = source_sheet.Cells(source_sheet.Rows.Count, col).End(xlUp).Row
    For source_row = starting_row To last_row
        
        Project = source_sheet.Cells(source_row, col).Value
        
        If Len(Project) > 0 Then
            'add a new workbook if one doesn't already exist
            If Not dict.exists(Project) Then
                Set dict(Project) = Workbooks.Add()
                dict(Project).Worksheets(1).Name = Project
                'optionally save to a specific location...
            End If
            'copy row to relevant sheet
            source_sheet.Rows(source_row).Copy _
                dict(Project).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        
        End If
    Next source_row

End Sub