vba to fetch email id and send emails automatically

[abi123]

Hi
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,

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

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 need 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

[Sintek]

Hi abi123

Welcome to the Forum.
In future please view the forum rules before posting. Your post does not comply with rule #3.

3. Use code tags around code. Posting code without them makes your code hard to read and difficult to be copied for testing. Highlight your code and click the [#] button at the top of the post window.

Unfortunately we are not able to assist until you have corrected this...

[abi123]

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.*
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.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
End Sub

Please help.

Sintek,
Can you check if this is okay?