vba to fetch email id and send emails automatically

A

Abinav

New Member
Joined
Sep 21, 2017
Messages
36
Hi
I am trying to create a macro to send emails automatically via outlook. Currently i have the raw data which i have sorted according to the Send code mentioned below ,separated the sheets based on the account field. Now i need a code to send email to specific email id based on the send code along with their attachments created(Separated in the same workbook with name of the send code). I want the subject to be the same as send code & allow me to enter the body of the email. Kindly help me.


Sample of send code and their corresponding email id,
Account Send Code Email ID
80000 PTN sherine@gmail.com
80004 RB Mathew@gmail.com
80064 PTN Abi@gmail.com
80068 RS radha@gmail.com
80069 RB-AR sow@gmail.com


Code i have used for separating sheets :


Sub attachments()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 9
Set ws = Sheets("EmailOutput")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:I1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub


Column A has the Account field and Column I has the Send code in the prepared sheets for attachment.


Thank you
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Sort by date Sort by votes
Abinav said:
Hi
I am trying to create a macro to send emails automatically via outlook. Currently i have the raw data which i have sorted according to the Send code mentioned below ,separated the sheets based on the account field. Now i need a code to send email to specific email id based on the send code along with their attachments created(Separated in the same workbook with name of the send code). I want the subject to be the same as send code & allow me to enter the body of the email. Kindly help me.


Sample of send code and their corresponding email id,
Account Send Code Email ID
80000 PTN sherine@gmail.com
80004 RB Mathew@gmail.com
80064 PTN Abi@gmail.com
80068 RS radha@gmail.com
80069 RB-AR sow@gmail.com


Code i have used for separating sheets :


Sub attachments()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 9
Set ws = Sheets("EmailOutput")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:I1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub


Column A has the Account field and Column I has the Send code in the prepared sheets for attachment.


Thank you
Click to expand...


Hello

I am using the below code to send emails. It is sending the entire workbook as attachment to all the specified email id.

I want to alter the code to send the email to the specific email id based on the sheet name as prepared, for example

Sheet name/Send code- PTN
Account - 80000
Send email to sherine@gmail.com

Code-

Sub sendemail()


Dim xOutlook As Object
Dim xMailItem As Object
Dim xRg As Range
Dim xCell As Range
Dim xEmailAddr As String
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.<wbr>Address
Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOutlook = CreateObject("Outlook.<wbr>Application")
Set xMailItem = xOutlook.CreateItem(0)
For Each xCell In xRg
If xCell.Value Like "*@*" Then
If xEmailAddr = "" Then
xEmailAddr = xCell.Value
Else
xEmailAddr = xEmailAddr & ";" & xCell.Value
End If
End If
Next
With xMailItem
.To = xEmailAddr
.CC = ""
.Subject = ""
.Body = ""
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
Set xOutlook = Nothing
Set xMailItem = Nothing
End Sub

Please help.
 
Upvote 0
.
You could paste this into the ThisWorkbook module :

Code: 
Option Explicit


Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Range("A1").Value = ActiveSheet.Name
End Sub

When the Input Box appears asking for a range ... select Cell A1 on the page you want to email.

The macro takes the Tab Name (which you indicated has the name = to the email of the vendor data on that page) and places it in Cell A1 of the page.
 
Upvote 0
Hi Logit

Thanks for your reply.

I am getting and error "Argument not optional".
Can you tell which part of the code i need to paste the code which you suggested.

Dim xOutlook As Object Dim xMailItem As Object
Dim xRg As Range
Dim xCell As Range
Dim xEmailAddr As String
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOutlook = CreateObject("Outlook.Application")
Set xMailItem = xOutlook.CreateItem(0)
For Each xCell In xRg
If xCell.Value Like "*@*" Then
If xEmailAddr = "" Then
xEmailAddr = xCell.Value
Else
xEmailAddr = xEmailAddr & ";" & xCell.Value
End If
End If
Next
With xMailItem
.To = xEmailAddr
.CC = ""
.Subject = ""
.Body = ""
.attachments.Add ActiveWorkbook.FullName
.Display
End With
Set xOutlook = Nothing
Set xMailItem = Nothing

Many Thanks
 
Upvote 0
.
I edited your original macro on the .To line (no other changes were made to the original macro):

Code: 
Option Explicit


Sub sendemail()


Dim xOutlook As Object
Dim xMailItem As Object
Dim xRg As Range
Dim xCell As Range
Dim xEmailAddr As String
Dim xTxt As String


On Error Resume Next


xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)


    If xRg Is Nothing Then Exit Sub
    
    Set xOutlook = CreateObject("Outlook.Application")
    Set xMailItem = xOutlook.CreateItem(0)
    
        For Each xCell In xRg
            If xCell.Value Like "*@*" Then
                If xEmailAddr = "" Then
                    xEmailAddr = xCell.Value
                    Else
                    xEmailAddr = xEmailAddr & ";" & xCell.Value
                End If
            End If
        Next
        
    With xMailItem
        .To = xRg.Value     '<-----------------------------------------Changed this line
        .CC = ""
        .Subject = ""
        .Body = ""
        .attachments.Add ActiveWorkbook.FullName
        .Display
    End With
    
Set xOutlook = Nothing
Set xMailItem = Nothing


End Sub


Also added a small macro to the ThisWorkbook Module :

Code: 
Option Explicit


Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Range("A1").Value = ActiveSheet.Name
End Sub


You may download the sample workbook from this link : https://www.amazon.com/clouddrive/share/r2zH7hwjAUoPEODsah9dMg7nNAoCphX4EJk0FLLDKCB

I understand you are just starting VBA programming and copied a macro from a renowned website ... It makes it alot easier for others to 'read' code if you become accustomed to indenting where appropriate.

Good programming practice.

Let me know how these changes work for you. :)
 
Upvote 0
Hi Logit

While the code is running i dont know which part of the range i need to select in the masterdata sheet in the Kutools function. Also tell me where i need to include this code.

Code: 
[/COLOR][COLOR=#333333]Option Explicit[/COLOR]
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Range("A1").Value = ActiveSheet.Name 
[FONT=Verdana]End Sub[/FONT][COLOR=#333333]

The entire workbook is getting attached. help me to attached each sheets.

Below is the refined request of my requirement , Hope i am not confusing..

I am new to VBA as you told :(


-----------------


I have a raw data which has to be sorted and for which i have given codes. Once the data is sorted I have given a code to separate sheets based on column (Col I) filter. Below is the same code i have used,


Code: 
Sub attachments()[/FONT]
[FONT=arial]Dim lr As Long[/FONT]
[FONT=arial]Dim ws As Worksheet[/FONT]
[FONT=arial]Dim vcol, i As Integer[/FONT]
[FONT=arial]Dim icol As Long[/FONT]
[FONT=arial]Dim myarr As Variant[/FONT]
[FONT=arial]Dim title As String[/FONT]
[FONT=arial]Dim titlerow As Integer[/FONT]
[FONT=arial]vcol = 9[/FONT]
[FONT=arial]Set ws = Sheets("EmailOutput")[/FONT]
[FONT=arial]lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row[/FONT]
[FONT=arial]title = "A1:I1"[/FONT]
[FONT=arial]titlerow = ws.Range(title).Cells(1).Row[/FONT]
[FONT=arial]icol = ws.Columns.Count[/FONT]
[FONT=arial]ws.Cells(1, icol) = "Unique"[/FONT]
[FONT=arial]For i = 2 To lr[/FONT]
[FONT=arial]On Error Resume Next[/FONT]
[FONT=arial]If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.<wbr>Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then[/FONT]
[FONT=arial]ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)[/FONT]
[FONT=arial]End If[/FONT]
[FONT=arial]Next[/FONT]
[FONT=arial]myarr = Application.WorksheetFunction.<wbr>Transpose(ws.Columns(icol).<wbr>SpecialCells(<wbr>xlCellTypeConstants))[/FONT]
[FONT=arial]ws.Columns(icol).Clear[/FONT]
[FONT=arial]For i = 2 To UBound(myarr)[/FONT]
[FONT=arial]ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""[/FONT]
[FONT=arial]If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then[/FONT]
[FONT=arial]Sheets.Add(after:=Worksheets(<wbr>Worksheets.Count)).Name = myarr(i) & ""[/FONT]
[FONT=arial]Else[/FONT]
[FONT=arial]Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.<wbr>Count)[/FONT]
[FONT=arial]End If[/FONT]
[FONT=arial]ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")[/FONT]
[FONT=arial]Sheets(myarr(i) & "").Columns.AutoFit[/FONT]
[FONT=arial]Next[/FONT]
[FONT=arial]ws.AutoFilterMode = False[/FONT]
[FONT=arial]ws.Activate[/FONT]
[FONT=arial]End Sub[/FONT]
[FONT=arial]


Details entered in the Masterdata sheet:


Account Send Code Email ID
80000 PTN sherine@gmail.com
80004 RB Mathew@gmail.com
80064 PTN Abi@gmail.com
80068 RS radha@gmail.com
80069 RB-AR sow@gmail.com




Till this point i was able to create. I need your help in sending automatic email via outlook as below,




> Once the sheets are separated with the sheet name (Send code in the masterdata sheet), I want to send email automatically to the corresponding email id. For example,


Sheet- PTN have the details that needs to be sent to sherine@gmail.com automatically with the sheet PTN as attachment,


I also want to input the body of the email every time. I have multiple send code and their corresponding email id in the masterdata sheet.
Please help me with the code.




Many Thanks

 
Upvote 0
.
This FORUM doesn't provide a means to attach a file. Having your file in hand here would be great. If you intend to do so, you will need to use a 'cloud' storage system like DROPBOX.COM, AMAZON.COM storage, GOOGLE storage, etc. Then provide a link
to the file as I did in my last post where the file is stored on AMAZON CLOUD.

While the code is running i dont know which part of the range i need to select in the masterdata sheet in the Kutools function. Also tell me where i need to include this code.


Option Explicit
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Range("A1").Value = ActiveSheet.Name
End Sub
Click to expand...


To get to the VBE, RIGHT CLICK one of the sheet tabs, select VIEW CODE.

On the left side you will see a small window with the Sheets listed. Double click on THISWORKBOOK, then paste the above macro into the large window on the right side.

From the MENU BAR up top, click INSERT ... select MODULE. In the large window to the right, paste the macro code seen below :

Code: 
Option Explicit


Sub sendemail()


Dim xOutlook As Object
Dim xMailItem As Object
Dim xRg As Range
Dim xCell As Range
Dim xEmailAddr As String
Dim xTxt As String


On Error Resume Next


xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the arresses list:", "Kutools for Excel", xTxt, , , , , 8)


    If xRg Is Nothing Then Exit Sub
    
    Set xOutlook = CreateObject("Outlook.Application")
    Set xMailItem = xOutlook.CreateItem(0)
    
        For Each xCell In xRg
            If xCell.Value Like "*@*" Then
                If xEmailAddr = "" Then
                    xEmailAddr = xCell.Value
                    Else
                    xEmailAddr = xEmailAddr & ";" & xCell.Value
                End If
            End If
        Next
        
    With xMailItem
        .To = xRg.Value     '<-----------------------------------------Changed this line
        .CC = ""
        .Subject = ""
        .Body = ""
        .attachments.Add ActiveWorkbook.FullName
        .Display
    End With
    
Set xOutlook = Nothing
Set xMailItem = Nothing


End Sub

I am presuming you have already attached a COMMAND BUTTON to the first worksheet ? If not, go back to viewing all of the sheets. Select SHEET1, on the menu bar up top, click
DEVELOPER / INSERT. A small window/form appears. Click the small button in the upper left corner. Now position your cursor somewhere on the sheet and left click.

A small form should appear with the macro "sendemail" displayed. Double-click the word "sendemail". The form should close and the command button should now be attached to that
macro. You will probably need to left click once somewhere on the sheet to get rid of the small dots surrounding the Command Button.

Save and close the workbook. Re-Open the workbook. Each sheet should have the sheet name located in cell A1. If not, go from sheet to sheet to make it appear in A1, then go back to
Sheet1.

Click the command button. If everything worked as designed you should have an email show up, with the workbook as an attachment, and the email in TO should be the Sheet name.

As I understood from your first posts, each account/vendor you wish to email is located on a separate worksheet, the sheet tab name is their email address. So, these macros will take
their email address from the sheet tab, paste it into cell A1 from which you can use when sending an email.

When you click the Command Button an INPUT BOX shows asking for a range. Click on cell A1 and then OK. The email address from A1 is transferred to the email TO field.

If you need to send an email to an account/vendor located on another sheet, click the CommandButton, then change to the sheet you need, then click A1.

-----------------------------------------

Regarding the BODY of the email. Will it always be the same or will the message in the body change from time to time ?
 
Upvote 0
.
I get to the SORT stage but nothing is transferred to the EMAIL OUTPUT sheet. The macros stop at that point.

???
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
112
Scifo
S
S
  • Solved
VBA Parse Data. (do not want title to copy over Every time)
Replies
2
Views
471
Scifo
S
S
  • Question
VBA code_How to keep in Excel header row included when splitting worksheet to separate worksheets
Replies
1
Views
662
rlv01
R
S
  • Solved
Parse Data - Paste Range to new sheets as values only.
Replies
9
Views
571
Scifo
S
M
  • Question
Need to keep data only for one cell value.
Replies
0
Views
442
MDMitch
M

Forum statistics

Threads
1,214,646
Messages
6,120,715
Members
448,985
Latest member
chocbudda

Share this page

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