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.
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