email filtered range as attachment through outlook

[nagasree]

Hello All, I have a master sheet in which column C has names of employees, and i have data from Column A to Column AE, The number of rows change from day to day.

I need a macro to send the rows to each employees as separate attachment via email, for example: if raj has 50 rows, it must get emailed to him as a separate excel attachment with all the formats through outlook, then ram has 60, those 60 rows alone must be sent to him as separate attachment.

The employee name in column C is the email id of each employees. there are more than 30 employees, so filtering and copying and pasting into new sheet and then attaching to mail takes a lot of time, please help me out.

I have been searching all over internet but couldnt find any, so please help me.

 

[EFANYoutube]

Hi nagasree
I have thrown together something but the Outlook component of it is slow and a bit ugly, sorting a better solution, but have a play in a copy one first

Sub SendIndividual()


Dim sht As Worksheet
Dim Users() As Variant
Dim wb As Workbook
'
With Sheet1
'Get list of employees
    With Application.WorksheetFunction
        Users = .Unique(Range("C2:C45"))
        Users = .Sort(Users)
    End With
   
    For i = 1 To UBound(Users)
        If IsEmpty(Users(i, 1)) = False Then
            .Range("$A$1:$AE$10040").AutoFilter Field:=3, Criteria1:=Users(i, 1)
            .Cells.Copy
            Set wb = Application.Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial xlPasteAll
            wb.Activate
            Application.Dialogs(xlDialogSendMail).Show arg1:=Users(i, 1), arg2:="Your subject here"
            .Cells.AutoFilter
            wb.Close False
        End If
    Next i
End With
End Sub

 

[nagasree]

Hi nagasree
I have thrown together something but the Outlook component of it is slow and a bit ugly, sorting a better solution, but have a play in a copy one first

Sub SendIndividual()


Dim sht As Worksheet
Dim Users() As Variant
Dim wb As Workbook
'
With Sheet1
'Get list of employees
    With Application.WorksheetFunction
        Users = .Unique(Range("C2:C45"))
        Users = .Sort(Users)
    End With
  
    For i = 1 To UBound(Users)
        If IsEmpty(Users(i, 1)) = False Then
            .Range("$A$1:$AE$10040").AutoFilter Field:=3, Criteria1:=Users(i, 1)
            .Cells.Copy
            Set wb = Application.Workbooks.Add
            wb.Sheets(1).Range("A1").PasteSpecial xlPasteAll
            wb.Activate
            Application.Dialogs(xlDialogSendMail).Show arg1:=Users(i, 1), arg2:="Your subject here"
            .Cells.AutoFilter
            wb.Close False
        End If
    Next i
End With
End Sub

Hi it shows error as unable to get the unique property of the worksheet function class in Users = .Unique(Range("C2:C45")) line

 

[EFANYoutube]

Appoligies, The UNIQUE() functioon is only for 365 users, I should have checked first

 

[Sequoyah]

Hi nagasree
try this code

Sub CreateEmails_nagasree()
'https://www.mrexcel.com/board/threads/email-filtered-range-as-attachment-through-outlook.1221406/

    Dim targetWorkbook As Workbook
    Dim objFSO      As Object
    Dim varTempFolder As Variant, v As Variant
    Dim OutApp      As Object, OutMail As Object, rng As Range, i As Long
    Dim AttFile     As String
    v = Range("A2").CurrentRegion.Value
    
    Set OutApp = CreateObject("Outlook.Application")
    Application.ScreenUpdating = False
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    varTempFolder = objFSO.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss")
    objFSO.CreateFolder (varTempFolder)
    
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(v)
            If Not .exists(v(i, 3)) Then
                .Add v(i, 3), Nothing
                With ActiveSheet
                    .Range("A1").AutoFilter 3, v(i, 3)
                    Set rng = .AutoFilter.Range
                    Set targetWorkbook = Workbooks.Add
                    .UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(Sheets.Count).Range("A1")
                    AttFile = Format(Now, "yyyy-mm-dd-hh-mm-ss") & ".xlsx"
                    
                    With targetWorkbook
                        .ActiveSheet.Columns.AutoFit
                        .SaveAs varTempFolder & "\" & AttFile
                        .Close
                    End With
                    
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .to = v(i, 3)
                        .Subject = "My Subject"
                        .HTMLBody = "test"
                        .Attachments.Add varTempFolder & "\" & AttFile
                        .Display
                        ' .Send
                    End With
                End With
            End If
        Next i
    End With
    Range("A1").AutoFilter
    
    With objFSO
        .deletefile varTempFolder & "\*.*", True
        .DeleteFolder varTempFolder
    End With
    
    Application.ScreenUpdating = True
End Sub

 

[nagasree]

Hi nagasree
try this code

Sub CreateEmails_nagasree()
'https://www.mrexcel.com/board/threads/email-filtered-range-as-attachment-through-outlook.1221406/

    Dim targetWorkbook As Workbook
    Dim objFSO      As Object
    Dim varTempFolder As Variant, v As Variant
    Dim OutApp      As Object, OutMail As Object, rng As Range, i As Long
    Dim AttFile     As String
    v = Range("A2").CurrentRegion.Value
 
    Set OutApp = CreateObject("Outlook.Application")
    Application.ScreenUpdating = False
 
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    varTempFolder = objFSO.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss")
    objFSO.CreateFolder (varTempFolder)
 
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(v)
            If Not .exists(v(i, 3)) Then
                .Add v(i, 3), Nothing
                With ActiveSheet
                    .Range("A1").AutoFilter 3, v(i, 3)
                    Set rng = .AutoFilter.Range
                    Set targetWorkbook = Workbooks.Add
                    .UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(Sheets.Count).Range("A1")
                    AttFile = Format(Now, "yyyy-mm-dd-hh-mm-ss") & ".xlsx"
                 
                    With targetWorkbook
                        .ActiveSheet.Columns.AutoFit
                        .SaveAs varTempFolder & "\" & AttFile
                        .Close
                    End With
                 
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .to = v(i, 3)
                        .Subject = "My Subject"
                        .HTMLBody = "test"
                        .Attachments.Add varTempFolder & "\" & AttFile
                        .Display
                        ' .Send
                    End With
                End With
            End If
        Next i
    End With
    Range("A1").AutoFilter
 
    With objFSO
        .deletefile varTempFolder & "\*.*", True
        .DeleteFolder varTempFolder
    End With
 
    Application.ScreenUpdating = True
End Sub

It shows error as file is bigger than server allows to attach, file size is 84.4 MB

 

[Sequoyah]

Hi @nagasree
there must be some problem in the used range of your file. Try running this code, preferably on a copy of your original file, before running the macro I posted earlier

Sub ResetLastCell()
 Dim wks     As Worksheet, x As Long, y As Long
 Dim Cel    As Range, LastRow As Range, LastCol As Range, LastCell As Range
                
                Set wks = ThisWorkbook.ActiveSheet
                
                With wks
                                        
                    Set LastRow = wks.Cells.Find(What:="*", After:=wks.Range("A1"), SearchDirection:=xlPrevious, searchorder:=xlRowThenColumn)
                    Set LastCol = wks.Cells.Find(What:="*", After:=wks.Range("A1"), SearchDirection:=xlPrevious, searchorder:=xlColumnThenRow)
                    On Error Resume Next
                    Set LastCell = Intersect(LastRow.EntireRow, LastCol.EntireColumn)
                    Range(LastCell.Offset(1, 0), LastCell.Offset(1, 0).End(xlDown)).EntireRow.ClearFormats
                    Range(LastCell.Offset(0, 1), LastCell.Offset(0, 1).End(xlToRight)).EntireColumn.ClearFormats
                    On Error GoTo 0
                    x = .UsedRange.Rows.Count
                    y = .UsedRange.Columns.Count
                    .Cells(x, y).Select
                End With
            End Sub