email filtered range as attachment through outlook

nagasree

New Member
Joined
Oct 30, 2021
Messages
30
Office Version
  1. 2019
Platform
  1. Windows
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.
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
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
VBA Code:
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
 
Upvote 0
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
VBA Code:
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
 
Upvote 0
Appoligies, The UNIQUE() functioon is only for 365 users, I should have checked first
 
Upvote 0
Hi nagasree
try this code
VBA 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
 
Upvote 0
Hi nagasree
try this code
VBA 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
 
Last edited:
Upvote 0
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
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,893
Messages
6,175,239
Members
452,621
Latest member
Laura_PinksBTHFT

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top