In this tutorial, we are going to write an automation script to split a table in Excel using VBA.

Using VBA, you can break down a source worksheet to multiple Excel file based on the values in the selected key columns, and doing so, will keep your data secure without oversharing unwanted information. Many solutions out there rely on 3rd party addins, require payment to download the software. With VBA, it is free, and you can modify the script to meet your specific need.

Buy Me a Coffee? Your support is much appreciated!
PayPal Me: https://www.paypal.me/jiejenn/5
Venmo: @Jie-Jenn

Download the source file → LINK

Download the final file → LINK

Source Code:

Option Explicit

Const Target_Folder As String = "<Target Folder Path>"
Dim wsSource As Worksheet, wsHelper As Worksheet
Dim LastRow As Long, LastColumn As Long

Sub SplitDataset()

    Dim collectionUniqueList As Collection
    Dim i As Long

    Set collectionUniqueList = New Collection

    Set wsSource = ThisWorkbook.Worksheets("Registered_Business_Locations_-")
    Set wsHelper = ThisWorkbook.Worksheets("Helper")


    wsHelper.Cells.ClearContents

    With wsSource
        .AutoFilterMode = False

        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column

        If .Range("A2").Value = "" Then
            GoTo Cleanup
        End If

        Call Init_Unique_List_Collection(collectionUniqueList, LastRow)

        Application.DisplayAlerts = False

        For i = 1 To collectionUniqueList.Count
                SplitWorksheet (collectionUniqueList.Item(i))
        Next i

        ActiveSheet.AutoFilterMode = False

    End With

Cleanup:

    Application.DisplayAlerts = True
    Set collectionUniqueList = Nothing
    Set wsSource = Nothing
    Set wsHelper = Nothing

End Sub

Private Sub Init_Unique_List_Collection(ByRef col As Collection, ByVal SourceWS_LastRow As Long)

    Dim LastRow As Long, RowNumber As Long

    wsSource.Range("G2:G" & SourceWS_LastRow).Copy wsHelper.Range("A1")

    With wsHelper

        If Len(Trim(.Range("A1").Value)) > 0 Then

            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row

            .Range("A1:A" & LastRow).RemoveDuplicates 1, xlNo

            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row

            .Range("A1:A" & LastRow).Sort .Range("A1"), Header:=xlNo

            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row

            On Error Resume Next
            For RowNumber = 1 To LastRow
                col.Add .Cells(RowNumber, "A").Value, CStr(.Cells(RowNumber, "A").Value)
            Next RowNumber

        End If

    End With

End Sub

Private Sub SplitWorksheet(ByVal Category_Name As Variant)

    Dim wbTarget As Workbook

    Set wbTarget = Workbooks.Add

    With wsSource

        With .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
            .AutoFilter .Range("G1").Column, Category_Name

            .Copy

            wbTarget.Worksheets(1).Paste
            wbTarget.Worksheets(1).Name = Category_Name

            wbTarget.SaveAs Target_Folder & Category_Name & ".xlsx", 51
            wbTarget.Close False

        End With

    End With

    Set wbTarget = Nothing

End Sub