Create multiple excel files keeping only specific values in column A from a master sheet

Question

I am really struggling in creating a macro that from a master Excel file creates multiple Excel files based on the values in the first column. More specifically, I have in column "A" some categories, and based on all the categories (ITT1, ITT2, ITT3, ITT4 and ITT5) I would like to create multiple excel files containing the sheet with just 1 category. At the moment, I have been able to save just 1 file with 1 category. But I cannot do it with multiple. Could you kindly help me please? I am stuck.

Sub Split()

Dim location As String
location = "Z:\Incent_2022\ORDINARIA\RETAIL-WHS\Andamento\Q4\Andamento\Novembre\And. Inc Q4_ITT1.xlsm"
ActiveWorkbook.SaveAs Filename:=location, FileFormat:=52

With ActiveSheet
    Const FirstRow As Long = 6

    Dim LastRow As Long
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row  ' get last used row in column A

    Dim Row As Long
    
    For Row = LastRow To FirstRow Step -1
        If Not .Range("A" & Row).Value = "ITT1" Then
            .Range("A" & Row).EntireRow.Delete
     End If
    Next Row
    End With
    
ActiveWorkbook.Close SaveChanges:=True

End Sub

Answer 1

This is working for me perfectly. There are a few things you will need to change to fit your sheet.

Option Explicit

Sub Export_Files()
    
    Dim I As Long
    Dim lRow As Long
    Dim SaveLoc As String
    Dim OutWB As Workbook
    Dim TypeList
    Dim TypeRG As Range
    
    ' > Create Unique List of Used Types
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    Set TypeRG = Sheet1.Range("A2:A" & lRow)
    TypeList = Application.WorksheetFunction.Unique(TypeRG)
    
    ' > My Directory
    SaveLoc = "C:\Users\cameron\Documents\temp\"
    
    ' >
    For I = 1 To UBound(TypeList, 1)
        'Create File:
        Set OutWB = Workbooks.Add
        OutWB.SaveAs SaveLoc & TypeList(I, 1)
        
        'Transfer Data to file:
        Sheet1.Range("A1:E" & lRow).AutoFilter Field:=1, Criteria1:=TypeList(I, 1)
        Sheet1.Range("A1:E" & lRow).SpecialCells(xlCellTypeVisible).Copy
        OutWB.Worksheets(1).Paste
        OutWB.Save
        OutWB.Close
        
    Next I
    
End Sub

To Change:

• SaveLoc - to your preferred directory
• The TypeRG range if yours is not in A Column (also your lRow maybe)
• your autofilter range if your data range is larger than mine.

Exaple of my data:

Answer 2

Export Split Data

Sub ExportSplitData()
    
    ' Define constants.
    
    Const SRC_NAME As String = "Sheet1"
    Const SRC_FIRST_CELL As String = "A5"
    Const SRC_CRITERIA_COLUMN As Long = 1
    
    Const DST_FOLDER As String _
        = "Z:\Incent_2022\ORDINARIA\RETAIL-WHS\Andamento\Q4\Andamento\Novembre\"
    Const DST_NAME_LEFT As String = "And. Inc Q4_"
    Const DST_EXTENSION As String = ".xlsm"
    
    ' Reference the Source worksheet.
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = swb.Sheets(SRC_NAME)
    
    Application.ScreenUpdating = False
    
    ' To leave the source workbook intact, export the worksheet
    ' to a new (helper) workbook and reference the range (there).
    
    sws.Copy
    Dim hwb As Workbook: Set hwb = Workbooks(Workbooks.Count)
    
    Dim hws As Worksheet: Set hws = hwb.Sheets(SRC_NAME)
    If hws.FilterMode Then hws.ShowAllData
    
    Dim hfCell As Range: Set hfCell = hws.Range(SRC_FIRST_CELL)
    
    Dim hrg As Range, hdrg As Range, hfrrg As Range, hrCount As Long
    
    With hws.UsedRange
        Set hfrrg = Intersect(hfCell.EntireRow, .Cells)
        Set hrg = hfrrg.Resize(.Rows.Count + .Row - hfrrg.Row)
        hrCount = hrg.Rows.Count
        Set hdrg = hrg.Resize(hrCount - 1).Offset(1) ' no headers
    End With
    
    ' Sort the range by the criteria column.
    
    hrg.Sort hrg.Columns(SRC_CRITERIA_COLUMN), xlAscending, , , , , , xlYes
    
    ' Write the unique values from the criteria column to a dictionary.
    
    Dim hData() As Variant: hData = hdrg.Columns(SRC_CRITERIA_COLUMN).Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim r As Long
    
    For r = 1 To hrCount - 1
        If Len(CStr(hData(r, 1))) > 0 Then
            dict(hData(r, 1)) = Empty
        End If
    Next r
    
    ' Loop through the keys of the dictionary and export
    ' the sorted helper worksheet to be processed in yet another file,
    ' the destination workbook.
    
    Dim dwb As Workbook, dws As Worksheet, drg As Range, ddrg As Range
    Dim rKey As Variant, dFilePath As String
    
    For Each rKey In dict.Keys
        
        hws.Copy
        
        Set dwb = Workbooks(Workbooks.Count)
        Set dws = dwb.Sheets(SRC_NAME)
        Set drg = dws.Range(hrg.Address) ' has headers
        Set ddrg = dws.Range(hdrg.Address) ' no headers
        
        drg.AutoFilter SRC_CRITERIA_COLUMN, "<>" & rKey ' filter
        ddrg.SpecialCells(xlCellTypeVisible).Delete xlShiftUp ' delete
        dws.AutoFilterMode = False ' turn off filter
        
        dFilePath = DST_FOLDER & DST_NAME_LEFT & rKey & DST_EXTENSION
        
        Application.DisplayAlerts = False
            dwb.SaveAs dFilePath, xlOpenXMLWorkbookMacroEnabled
        Application.DisplayAlerts = True
        
        dwb.Close SaveChanges:=False
    
    Next rKey
    
    ' Close the helper file.
    
    hwb.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    
    ' Inform.
    
    MsgBox "Split data exported.", vbInformation

End Sub