Split Master Workbook In To Individual Files And Attach To Separate Mails

[Excel Fox]

I've come across many situations where we had to split a master workbook in to multiple workbooks each containing a group of data based on unique values in a specific column. In addition to that common requirement, I was also asked whether we can attach each of those individual workbook files in to separate emails, which are basically ready to be sent to the respective recipient. Here's something on those lines, that I did for someone recently



Option Explicit

Sub SplitFile()

Dim wbk As Workbook
Dim strPath As String
Dim objDic As Object
Dim var As Variant
Dim lng As Long
Dim objOutlook As Object
Dim objOutlookMsg As Object

On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo -1: On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If

With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select the file to be split"
.Filters.Add "Excel 2007-13", "*.xlsx", 1
.AllowMultiSelect = False
.Show
If .SelectedItems.Count Then
strPath = .SelectedItems(1)
Else
MsgBox "Cancelled by user!", vbOKOnly, ""
Exit Sub
End If
End With
Set wbk = Workbooks.Open(Filename:=strPath)
Set objDic = CreateObject("Scripting.Dictionary")
With wbk.Sheets(1)
.AutoFilterMode = False
var = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
For lng = LBound(var) To UBound(var)
If Not IsEmpty(var(lng, 1)) Then
objDic.Item(var(lng, 1)) = 0
End If
Next lng
var = objDic.Keys
objDic.RemoveAll
With wbk.Sheets(1)
For lng = 0 To UBound(var)
.UsedRange.AutoFilter Field:=2, Criteria1:=var(lng)
With Workbooks.Add(xlWorksheet)
wbk.Sheets(1).UsedRange.Copy .Sheets(1).Cells(1)
.Sheets(1).UsedRange.Sort Key1:=.Sheets(1).Cells(2, 1), Order1:=xlAscending, Header:=xlYes
.SaveAs wbk.Path & "\" & var(lng), wbk.FileFormat
strPath = .FullName
.Close 0
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
' Add attachments to the message.
If Len(Dir(strPath)) <> 0 Then
.Attachments.Add strPath
Else
MsgBox "Unable to find the specified attachment."
End If
.Display
Kill strPath
End With
End With
Next lng
End With
wbk.Close 0

End Sub