Automate Excel File Splitting and Emailing with VBA
Streamline your Excel workflow with this comprehensive VBA code tutorial. Learn how to split Excel files based on unique identifiers and automatically email them, saving you time and effort.
VBA Code
Sub SplitFileByUniqueName()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim dict As Object
Dim newWB As Workbook
Dim fileName As String
Dim folderPath As String
Dim lastRow As Long
Dim lastColumn As Long
' Define the worksheet containing the data
Set ws = ThisWorkbook.Sheets("Data")
' Find the last row in column R
lastRow = ws.Cells(ws.Rows.Count, "R").End(xlUp).Row
' Define the range containing the data
Set rng = ws.Range("R2:R" & lastRow)
' Initialize dictionary to store unique names and their corresponding data ranges
Set dict = CreateObject("Scripting.Dictionary")
' Add unique names and their data ranges to the dictionary
For Each cell In rng
If Not dict.exists(cell.Value) Then
' Find the last column in the current row
lastColumn = ws.Cells(cell.Row, ws.Columns.Count).End(xlToLeft).Column
' Add the data range for the unique name to the dictionary
Set dict(cell.Value) = ws.Range(ws.Cells(cell.Row, 1), ws.Cells(cell.Row, lastColumn))
Else
' Find the last column in the current row
lastColumn = ws.Cells(cell.Row, ws.Columns.Count).End(xlToLeft).Column
' Union the data range for the unique name with the existing data range in the dictionary
Set dict(cell.Value) = Union(dict(cell.Value), ws.Range(ws.Cells(cell.Row, 1), ws.Cells(cell.Row, lastColumn)))
End If
Next cell
' Set the folder path to save the split files
folderPath = ThisWorkbook.Path & "\SplitFiles\" ' Change "SplitFiles" to your desired folder name
' Create the folder if it doesn't exist
If Dir(folderPath, vbDirectory) = "" Then
MkDir folderPath
End If
' Loop through each unique name and create separate files
For Each Key In dict.keys
' Copy header row
ws.Rows(1).Copy
' Copy data for current unique name to new workbook
Set newWB = Workbooks.Add
newWB.Sheets(1).Paste
' Copy data range for current unique name
dict(Key).Copy newWB.Sheets(1).Range("A2")
' Save new workbook with unique name as file name
fileName = folderPath & "Data_" & Key & ".xlsx"
newWB.SaveAs fileName
newWB.Close False
Next Key
' Clear clipboard
Application.CutCopyMode = False
' Show message when done
MsgBox "Files have been split and saved in folder: " & folderPath, vbInformation
MsgBox "This Code Create by RSNEXTWORLD"
End Sub
