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

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

Code:

---

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

---