Split File and send e-mail with Attachment

Task : split an excel file into separate files using particular customer
codes and then email these directly to a particular email account depending
on the  customer code(column A).



Option Explicit
Dim mycoll As Collection, rowcount As Long, myrng As Range, cell As Object, j As Long
Dim destinationwb As Workbook, outApp As Outlook.Application, outMail, newwb As Workbook

Sub createFiles()
Set mycoll = New Collection
On Error Resume Next
rowcount = ThisWorkbook.Sheets(1).Range("A3").End(xlDown).Row

Set myrng = ThisWorkbook.Sheets(1).Range("A3:A" & rowcount)
    For Each cell In myrng
        mycoll.Add cell, CStr(cell)


    Next
    For j = 1 To mycoll.Count
    Set outApp = New Outlook.Application
    Set outMail = outApp.CreateItem(olMailItem)
    Set destinationwb = Workbooks.Add
    destinationwb.SaveAs Filename:=ThisWorkbook.Path & "\" & mycoll(j), FileFormat:=56
        ThisWorkbook.Sheets(1).Range("A2").AutoFilter field:=1, Criteria1:=mycoll(j)
        ThisWorkbook.Sheets(1).UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=destinationwb.Sheets(1).Range("A1")
         Set newwb = ActiveWorkbook
     
     
        destinationwb.Save
        With outMail
            .To = mycoll(j) & "@yahoo.com"
            .Subject = "Monthly Account Summary"
         
            .Body = "Hi," & vbNewLine & "     Please find the attachment" & vbNewLine & "Regards," & vbNewLine & "Soumyendu"
         
            .Attachments.Add (ThisWorkbook.Path & "\" & newwb.Name)
            .Display
         
        End With
        Application.DisplayAlerts = False
        destinationwb.Close

         Application.DisplayAlerts = False
         Application.Wait (Now + TimeValue("0:00:02"))
         Application.SendKeys "%s" '
        Set outMail = Nothing
     
        Set outApp = Nothing
     
    Next
End Sub

https://drive.google.com/file/d/0B23eJ2xd9ODyb2VmRm1vblJjWGM/edit?usp=sharing