I'm working on a macro that creates Workbooks based on a filter and sends them out to a list of emails, one at a time, however, there may be more than one location per email and the loop is picking up each (next) cell, even if it's filtered out. Example table:
Location Email
1 asd#asd.com
2 asd#asd.com
3 asd#asd.com
4 qwe#qwe.com
I use another sheet to filter for each unique email and then load the locations into an array so it filters a table. Once that table is filtered I Copy and paste the contents into a new workbook, save it temporarily, attach it to the email and send it out. The problem is that when I reach the second unique email, the email contains values from previous rows (location 2 and 3) and so on. Here's the code:
Sub AutoEmailSend()
Dim rng As ListObject
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim TempFilePath As String
Dim TempFileName As String
Dim TempWB As Workbook
Dim LastRow As Long
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Detail Aging").ListObjects("Locations")
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Dim strbody As String
strbody = Worksheets("Body").Range("A1")
Dim strbody2 As String
strbody2 = Worksheets("Body").Range("A2")
Dim strbody3 As String
strbody3 = Worksheets("Body").Range("A3")
Dim strbody4 As String
strbody4 = Worksheets("Body").Range("A4")
Dim strbody5 As String
strbody5 = Worksheets("Body").Range("A5")
On Error GoTo cleanup
For Each cell In Sheets("Emails").Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Sheets("Locations").Range("A1:R1").AutoFilter Field:=12, Criteria1:=cell.Value
Dim RngOne As Range, cell2 As Range
Dim LastCell As Long
Dim arrList() As String, lngCnt As Long
With Sheets("Locations")
LastCell = .Range("D" & Sheets("Locations").Rows.Count).End(xlUp).Row
Set RngOne = .Range("D2:D" & LastCell)
End With
'load values into an array
lngCnt = 0
For Each cell2 In RngOne
If Not cell2.EntireRow.Hidden Then
ReDim Preserve arrList(lngCnt)
arrList(lngCnt) = cell2.Text
lngCnt = lngCnt + 1
End If
Next cell2
Sheets("Detail Aging").Range("A1:I1").AutoFilter Field:=1, Criteria1:=arrList, Operator:=xlFilterValues
With Worksheets("Detail Aging").ListObjects("Locations").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("Locations[[#Headers],[#Data],[Days Late]]"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Body").Range("B1").Formula = "=TEXT(Locations[[#Totals],[Total Balance]], ""$#,##0.00._);($#,##0.00)."")"
Dim strbody6 As String
strbody6 = Worksheets("Body").Range("B1")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.CC = Cells(cell.Row, "M").Value & "; " & Cells(cell.Row, "N").Value & "; " & Cells(cell.Row, "O").Value & "; " & Cells(cell.Row, "S").Value
.Subject = "Aging Report | " & Cells(cell.Row, "C").Value & " | " & Cells(cell.Row, "F").Value & " | " & Cells(cell.Row, "T").Value
.HTMLBody = "<BODY style=font-size:11pt;font-family:Arial>Dear Valued Customer,<BR><BR>" & _
strbody & "<BR><BR>" & _
strbody2 & "<B>" & strbody6 & "</B>" & " " & strbody3 & "<BR><BR>" & _
strbody4 & "<BR><BR>" & _
strbody5 & "<BR><BR>" & _
"<i><u>Please use ""Reply All"" when replying to this email. AR#Company.com is not a monitored email address.</u></i><BR><BR>" & _
"Thank you for your business!</BODY><BR>" & _
"<BODY style=font-size:12pt;font-family:Arial><B>" & Cells(cell.Row, "A").Value & " | <font color=""#d52427"">Company</font></B><BR>" & _
"<span style=font-size:11pt;font-family:Arial>" & Cells(cell.Row, "Q").Value & "<BR>" & _
Cells(cell.Row, "R").Value & "<BR>" & _
Cells(cell.Row, "S").Value & "<BR>" & _
"<font color=""#d52427"">www.Company.com</font></span></body><BR>"
rng.Range.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add (1)
Set TempWB = ActiveWorkbook
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
.Cells.EntireColumn.AutoFit
.Range("A1:J1").AutoFilter
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
.Name = "Aging Report"
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Aging Report " & Format(Now, "dd-mm-yy hh-mm-ss") & ".xlsx"
TempWB.SaveAs TempFilePath & TempFileName
.Attachments.Add TempWB.FullName
TempWB.Close savechanges:=False
Kill TempFilePath & TempFileName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
First email is correct like:
To: asd#asd.com
Cc: Person1#email.com; Company1#company.com
Subject: Aging Report | Cust1 | Custname1 | Col1
Attachment: Table containing correct details
Body Text Correct
Col1 Name | Company
Pos1
Phone1
Email1
www.Company.com
Second email however, is something like:
To: qwe#qwe.com
Cc: Person1#email.com; Company1#company.com (Should be Person2 and Company2)
Subject: Aging Report | Cust1 | Custname1 | Col1 (Should be Cust2 and so on)
Attachment: Table containing correct details
Body Text Correct
Col1 Name | Company (Should be Col2 and so on)
Pos1
Phone1
Email1
www.Company.com
I'm trying to provide as many details as possible. Thank you in advance.
Link with sample workbook: https://1drv.ms/x/s!At5Qdrytuugrlmt5NcJovACVdiNt
Edit - removed old answer as it did not address OP's issue.
Problem
You are using the row of the email address from the Emails sheet (the cell variable) when attempting to pull the collector. In your example of email #2, cell.Row is 3 because CustomerEmail2#Customer2.com appears in cell A3 of the Emails sheet.
Solution
You need to retrieve the first visible row number from the Locations sheet and use that in your references. Note the addition of the CollectorRow variable.
Sub AutoEmailSend()
Dim rng As ListObject
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim TempFilePath As String
Dim TempFileName As String
Dim TempWB As Workbook
Dim LastRow As Long
Dim CollectorRow As Long
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Detail Aging").ListObjects("Locations")
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Dim strbody As String
strbody = Worksheets("Body").Range("A1")
Dim strbody2 As String
strbody2 = Worksheets("Body").Range("A2")
Dim strbody3 As String
strbody3 = Worksheets("Body").Range("A3")
Dim strbody4 As String
strbody4 = Worksheets("Body").Range("A4")
Dim strbody5 As String
strbody5 = Worksheets("Body").Range("A5")
On Error GoTo cleanup
For Each cell In Sheets("Emails").Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Sheets("Locations").Range("A1:R1").AutoFilter Field:=12, Criteria1:=cell.Value
Dim RngOne As Range, cell2 As Range
Dim LastCell As Long
Dim arrList() As String, lngCnt As Long
With Sheets("Locations")
LastCell = .Range("D" & Sheets("Locations").Rows.Count).End(xlUp).Row
Set RngOne = .Range("D2:D" & LastCell)
End With
'load values into an array and get first visible row while we are at it
CollectorRow = 0
lngCnt = 0
For Each cell2 In RngOne
If Not cell2.EntireRow.Hidden Then
If CollectorRow = 0 Then CollectorRow = cell2.Row
ReDim Preserve arrList(lngCnt)
arrList(lngCnt) = cell2.Text
lngCnt = lngCnt + 1
End If
Next cell2
Sheets("Detail Aging").Range("A1:I1").AutoFilter Field:=1, Criteria1:=arrList, Operator:=xlFilterValues
With Worksheets("Detail Aging").ListObjects("Locations").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("Locations[[#Headers],[#Data],[Days Late]]"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Body").Range("B1").Formula = "=TEXT(Locations[[#Totals],[Total Balance]], ""$#,##0.00._);($#,##0.00)."")"
Dim strbody6 As String
strbody6 = Worksheets("Body").Range("B1")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.CC = Cells(CollectorRow, "M").Value & "; " & Cells(CollectorRow, "N").Value & "; " & Cells(CollectorRow, "O").Value & "; " & Cells(CollectorRow, "S").Value
.Subject = "Aging Report | " & Cells(CollectorRow, "C").Value & " | " & Cells(CollectorRow, "F").Value & " | " & Cells(CollectorRow, "T").Value
.HTMLBody = "<BODY style=font-size:11pt;font-family:Arial>Dear Valued Customer,<BR><BR>" & _
strbody & "<BR><BR>" & _
strbody2 & "<B>" & strbody6 & "</B>" & " " & strbody3 & "<BR><BR>" & _
strbody4 & "<BR><BR>" & _
strbody5 & "<BR><BR>" & _
"<i><u>Please use ""Reply All"" when replying to this email. AR#Company.com is not a monitored email address.</u></i><BR><BR>" & _
"Thank you for your business!</BODY><BR>" & _
"<BODY style=font-size:12pt;font-family:Arial><B>" & Cells(CollectorRow, "A").Value & " | <font color=""#d52427"">Company</font></B><BR>" & _
"<span style=font-size:11pt;font-family:Arial>" & Cells(CollectorRow, "Q").Value & "<BR>" & _
Cells(CollectorRow, "R").Value & "<BR>" & _
Cells(CollectorRow, "S").Value & "<BR>" & _
"<font color=""#d52427"">www.Company.com</font></span></body><BR>"
rng.Range.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add (1)
Set TempWB = ActiveWorkbook
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
.Cells.EntireColumn.AutoFit
.Range("A1:J1").AutoFilter
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
.Name = "Aging Report"
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Aging Report " & Format(Now, "dd-mm-yy hh-mm-ss") & ".xlsx"
TempWB.SaveAs TempFilePath & TempFileName
.Attachments.Add TempWB.FullName
TempWB.Close savechanges:=False
Kill TempFilePath & TempFileName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
I ran this modified code on your test workbook, and the second email has Customer2's information as intended.
Also, as a side note: since your code relies upon a list of emails in one sheet and filtering data in a different sheet, you would have unexpected behavior if an email in the Emails sheet had no lines in the Locations sheet. This may not be an issue for you - for instance, if another set of code builds the email list - but could be something to think about.
Related
I am trying to send Automate mail from Excel via Outlook mail to users. Within that i have requirement to send some Excel tables and graphs to certain users. The excel table should be placed after some text provided/written by sender and should retain the same table format in the email.
I am not able to get this functionality automate (sending excel table and graph in the email body) and require your help in sorting this out.
PS: I am using excel/Outlook 2010 (win)
Below is my overall code written as of now:
Sub Mail_to_MgmtTeam()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim rng As Range
Dim x As Integer, y As Integer
Dim total_Resource As Integer
Application.ScreenUpdating = False
' Delete the Temp sheets, if any (just precautionary step)
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Temp").Delete
Application.DisplayAlerts = True
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"
Sheets("Mail Details").Select
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Temp").Select
Range("A5").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("J:J").EntireColumn.Delete
Columns("A:A").EntireColumn.Delete
Range("A5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'' Below code not getting executed successfully
'Selection.Select
'Set rng = Sheets("Temp").Selection.SpecialCells(xlCellTypeVisible)
'rng.Copy
' NEED HELP Here : TO send this selected TABLE within the email BODY to someone...
' code for sending the mails form Excel
Sheets("Mail Details").Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Dear " & Cells(x + 5, 3).Value & ", " & _
vbNewLine & vbNewLine & _
"Below Table provides the overall statue of Pending Lists." & _
vbNewLine & vbNewLine & vbNewLine & _
"Thank You " & vbNewLine & "XYZ..."
On Error Resume Next
With OutMail
.To = Sheets("Mail Details").Range("D6").Value
.CC = ""
.BCC = ""
.Subject = "Excel Table Attached"
.Body = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Mails have been sent", vbDefaultButton1, "Mail Sent!!!"
End Sub
Thanks in advance
Kunal...
I was able to complete the task for which i had posted. I am posting the final code below for anyone who may need help in future on the similar line...
PS:
I have segmented into different sets for easy of use. Please copy each code and paste it in in 'module' back to back
The sheet name should be "RawData" and "ReportData"
The Table should be placed in sheet "RawData" and Column header should be in Row 5
In sheet "RawData", in K Column, Mail ID is mentioned
Macro #1
Option Explicit
Dim folder_path As String
Dim chart_no As Integer
Dim file_path As String
Sub mail_2_IBUhead()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim rng As Range
Dim x As Integer, y As Integer
Dim total_Resource As Integer
Application.ScreenUpdating = False
Sheets("RawData").Select
Call export_chart
Call Send_Automate_Mail
Sheets("RawData").Select
Range("A1").Select
'Delete the htm file we used in this function
Kill file_path & "Chart_1.png"
MsgBox "Draft Mails have been generated", vbDefaultButton1, "Mail Drafted!!!"
End Sub
Macro #2:
Private Sub Send_Automate_Mail()
' This macro would only send the mail...
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strbody_1 As String, strbody_2 As String, strbody_3 As String
Dim Start_row As Integer, Start_column As Integer, End_row As Integer, End_Column As Integer
' selecting the entire table range in the sheet
Sheets("RawData").Select
Range("A5").Select
Start_row = Selection.Row
Start_column = Selection.Column
Selection.End(xlToRight).Select
End_Column = Selection.Column
Range("A5").End(xlDown).Select
End_row = Selection.Row
Range(Cells(Start_row, 1), Cells(End_row, End_Column)).Select
Set rng = Selection.SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody_1 = "<BODY style=font-size:11pt;font-family:Calibri>Dear User,<p>" & _
" Below is the Graph.... <br> </BODY> "
strbody_2 = "<BODY style=font-size:11pt;font-family:Calibri>" & _
" Below is the Table... <br> </BODY> "
strbody_3 = "<BODY style=font-size:11pt;font-family:Calibri> This is an Automated mail. Please do not respond. <p> <p> " & _
" Regards, <br> Sender </BODY> "
file_path = folder_path & "\"
With OutMail
.To = Sheets("RawData").Range("k6").Value
.CC = ""
.BCC = ""
.Subject = "BE. RawData"
.Attachments.Add file_path & "Chart_1.png"
.htmlbody = strbody_1 & "<p>" & "<p>" & _
"<img src='cid:Chart_1.png'" & "width='1000' height='580'>" & "<br>" & "<p>" & _
strbody_2 & "<p>" & _
RangetoHTML(rng) & "<br>" & _
strbody_3
.Importance = 2
' display the e-mail message, change it to ".send" to send the mail on running the macro
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Macro #3:
Function RangetoHTML(rng As Range)
' this function is used in code "Send_Automate_Mail"
' do not change the code if you are new to coding :)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Macro #4:
Private Sub export_chart()
' this code will export all the graphs present in the sheet
Dim objCht As ChartObject
Dim x As Integer
folder_path = Application.ActiveWorkbook.Path
' for each graph present in the sheet, it will get exported
Sheets("ReportData").Select
x = 1
For Each objCht In ActiveSheet.ChartObjects
objCht.Chart.Export folder_path & "\Chart_" & x & ".png", "PNG"
x = x + 1
Next objCht
End Sub
Thanks,
Kunal...
I wrote code that breaks up a report filled with providers into individual reports for each provider then saved them into a folder on my desktop to be emailed to the providers.
Now I'd like to add some code that would automatically email these providers for me but would let me take a look first before being sent. Here's my old code.
Sub VendorSeperate()
Application.DisplayAlerts = False
wb1 = ActiveWorkbook.Name
SaveFolder397 = Format(Now(), "mm.dd.yy hh mm ss AM/PM")
SaveFolder400 = "C:\Users\johndoe\Desktop\Test\" & SaveFolder397
On Error Resume Next
MkDir SaveFolder400
On Error GoTo 0
[A2].Select
ActiveWindow.FreezePanes = True
batchdate = Format(Cells(2, 1), "mm.dd.yy") & " Sent " & Format(Now(), "mm.dd.yy")
LR1 = Columns(1).Find("*", SearchDirection:=xlPrevious).Row
For I = 2 To LR1 + 2
If Cells(I, 1) = "" And Cells(I - 1, 1) <> "" Then
providername = Trim(Cells(I - 1, 7))
ActiveSheet.Copy
Cells.AutoFilter Field:=7, Criteria1:="<>*" & providername & "*", Operator:=xlAnd
Rows("2:" & LR1 + 100).SpecialCells(xlCellTypeVisible).Delete
Cells.AutoFilter
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
ActiveWorkbook.SaveAs Filename:=SaveFolder400 & "\JD2.0 " & providername & " Ck Batch Date " & batchdate & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Workbooks(wb1).Activate
End If
Next I
End Sub
This is a really Simple Code to send an Email with Outlook. Maybe this can Help you.
Sub mail()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "abc#abc.ch"
.CC = ""
.BCC = ""
.Subject = "Subject line"
.Body = "Email text."
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I am working on a Code which can get the range/selection in the middle of the email body. The below code works a bit fine for me it does not captures the desired range in the middle of the email body. This will save my time to work manually.
Sub Selection_email()
Dim bStarted As Boolean
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim olMailItm As Object: Set olMailItm = olApp.CreateItem(0)
Dim rngTo As Range
Dim rngSubject As Range
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oItem = oOutlookApp.CreateItem(olMailItem)
With Active Sheet
Set rngTo = .Rng("E3")
Last = ActiveSheet.Cells(2, 4).Value
End With
With oItem
.SentOnBehalfOfName = ""
.To = rngTo.Value
.Cc = ""
.Subject = "" & Last & ""
.body = "Hello," & vbNewLine & vbNewLine & _
"Welcome to My World"& vbNewLine & vbNewLine & _
**HERE I NEED THE CODE TO PASTE THE RANGE FROM THE EXCEL FILE IT SHOULD BE FROM "A1:D6"**
"Thank you for your cooperation."
.Display.
If bStarted Then
oOutlookApp.Quit
End If
Set oOutlookApp = Nothing
End Sub
Option Explicit
Sub Selection_email()
Dim bStarted As Boolean
Dim olApp As Object
Dim oItem As Outlook.MailItem
Dim olMailItm As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim Last As Variant
Dim htmlString As String
Dim beginBody, endBody As String
Dim oOutlookApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oItem = oOutlookApp.CreateItem(olMailItem)
With ActiveSheet
Set rngTo = .Range("E3")
Last = ActiveSheet.Cells(2, 4).Value
End With
'create the HTML table first --
' this builds a string with proper HTML header info
htmlString = RangetoHTML(ActiveSheet.Range("A1:D6"))
'now add the email greeting to the body information
beginBody = Left(htmlString, InStr(1, htmlString, "<body>", vbTextCompare) + 6)
endBody = Right(htmlString, Len(htmlString) - InStr(1, htmlString, "<body>", vbTextCompare) + 5)
htmlString = beginBody & _
"Hello,<br><br>Welcome to My World<br><br>" & _
endBody
'now find the end of the table and add the signoff message
beginBody = Left(htmlString, InStr(1, htmlString, "</div>", vbTextCompare) + 6)
endBody = Right(htmlString, Len(htmlString) - InStr(1, htmlString, "</div>", vbTextCompare) + 5)
htmlString = beginBody & _
"<br><br>Thank you for your cooperation." & _
endBody
With oItem
.SentOnBehalfOfName = ""
.To = rngTo.Value
.CC = ""
.Subject = "" & Last & ""
.HTMLBody = htmlString
.Display
End With
If bStarted Then
oOutlookApp.Quit
End If
Set oOutlookApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
I'm assuming "A1:D6" is one merged ranged. You only want the top left cell in that case. If I've made an incorrect assumption let me know.
.body = "Hello," & vbNewLine & vbNewLine & _
"Welcome to My World"& vbNewLine & vbNewLine & _
Activesheet.range("A1").value & _
"Thank you for your cooperation."Replacing Activesheet with something more specific would also be a good idea but depends on your worksheets.
Edit
Using the RangeToHTML function found here: Paste specific excel range in outlook
Then change
.body = "Hello," & vbNewLine & vbNewLine & _
"Welcome to My World"& vbNewLine & vbNewLine & _
**HERE I NEED THE CODE TO PASTE THE RANGE FROM THE EXCEL FILE IT SHOULD BE FROM "A1:D6"**
"Thank you for your cooperation."
to
.HTMLBody = "Hello," & vbNewLine & vbNewLine & _
"Welcome to My World"& vbNewLine & vbNewLine & _
RangeToHTML(activesheet.range("A1:D6")) & _
"Thank you for your cooperation."
Hello I have these two macros in one module but when I run it only runs the first part where it deletes the rows but I would like it to also send the emails... I had some excellent help from #Simoco on the send part earlier but cant seem to figure out the combine part...
I tried to add the Call Sub... but no luck
Sorry about the length of the code...
Sub DeleteDuplicateRows()
Dim R As Long
Dim N As Long
Dim V As Variant
Dim rng As Range
Range("D2").Select
ActiveCell.FormulaR1C1 = "1"
Range("D2").Select
Selection.Copy
Range("A5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
Rows("1:3").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Columns("A:A").EntireColumn.AutoFit
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set rng = Application.Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(rng.Row, "#,##0")
N = 0
For R = rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If
V = rng.Cells(R, 1).Value
If V = vbNullString Then
If Application.WorksheetFunction.CountIf(rng.Columns(1), vbNullString) > 1 Then
rng.Rows(R).EntireRow.Delete
N = N + 1
End If
Else
If Application.WorksheetFunction.CountIf(rng.Columns(1), V) > 1 Then
rng.Rows(R).EntireRow.Delete
N = N + 1
End If
End If
Next R
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)
End Sub
Sub Send_Email()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim cel As Range
Dim SigString As String
Dim Signature As String
Dim lastrow As Long
Set OutApp = CreateObject("Outlook.Application")
SigString = Environ("appdata") & _
"\Microsoft\Signatures\GBS.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
For Each cel In Range("C2:C" & lastrow)
strbody = "Hi there" & cel.Offset(, -1) & vbNewLine & vbNewLine & _
"My name Is William, Please choose the following option ..." & vbNewLine & _
cel.Offset(, 3) & _
"I work at Fair" & vbNewLine & _
"Bye" & vbNewLine & _
"WH"
On Error Resume Next
With OutApp.CreateItem(0)
If cel.Value <> "" Then
.To = cel.Value
.CC = cel.Offset(0, 10).Value
.Body = strbody & vbNewLine & vbNewLine & Signature
Else
.To = cel.Offset(0, 10).Value
.Body = "Hello " & cel.Offset(, 9) & "! " & cel.Offset(, -1) & " is having this event" & vbNewLine & Signature
'.HTMLBody = strbody & vbNewLine & RangetoHTML(cel.Offset(, -2).Resize(, 4)) & vbNewLine & Signature
End If
'.BCC = ""
.Subject = "Choose your plan"
.Display
'.Attachments.Add ("C:\test.txt")
'.Send
End With
On Error GoTo 0
Next cel
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
If you execute a macro you call one procedure or one function. I assume you want to call Delete_Duplicate_Rows and Send_Email. To execute two procedures you can create one procedure that calls the other procedures
Sub Delete_And_Send()
Call Delete_Duplicate_Rows()
Call Send_Email()
End Sub
I'm totally new to Excel VBA. I am using Microsoft 2003 excel.
What my superior tasked me to do was to create a Leave Management System that tracks down an employee's amount of days left in terms of leave and from there, send an email down to her, her secretary and the employee regarding the status of approved or rejected.
I did try out some codes of VBA.. But I do not know how really the mail sending function works? Do i send the attachment out? Or when i entered some value in the code, it will auto send the whole attachment over? I'm really lost here, thank you!
Sub Mail_sheets()
Dim MyArr As Variant
Dim last As Long
Dim shname As Long
Dim a As Integer
Dim Arr() As String
Dim N As Integer
Dim strdate As String
For a = 1 To 253 Step 3
If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then
Exit Sub
End
Application.ScreenUpdating = False
last = ThisWorkbook.Sheets("mail").Cells(Rows.Count, _
a).End(xlUp).Row
N = 0
For shname = 1 To last
N = N + 1
ReDim Preserve Arr(1 To N)
Arr(N) = ThisWorkbook.Sheets("mail").Cells(shname, a).Value
Next shname
ThisWorkbook.Sheets(Arr).Copy
strdate = Format(Date, "dd-mm-yy") & " " & _
Format(Time, "h-mm-ss")
ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
& " " & strdate & ".xls"
With ThisWorkbook.Sheets("mail")
MyArr = .Range(.Cells(1, a + 1), .Cells(Rows.Count, _
a + 1).End(xlUp))
End With
ActiveWorkbook.SendMail MyArr, ThisWorkbook.Sheets("mail").Cells(1, a + 2).Value
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close False
Application.ScreenUpdating = True
Next a
End Sub
Here is an example on how to achieve what you want. Please amend it for your actual needs.
I did try out some codes of VBA.. But I do not know how really the mail sending function works? Do i send the attachment out?
You don't need to send the entire workbook as an attachment. You can send a simple email stating whether the leave is approved or rejected. If you need to support why you are rejecting or approving the leave then you can paste the relevant cells in the email. See this example.
I am assuming for a moment that you worksheet looks like this.
Now suppose the employee Siddharth wants to take a leave. As we can see in the snapshot, the employee has 0 leaves balance. So the request for leave will be declined and a mail will be shot to the relevant person/Dept
When you run the code, it will ask you to enter the employees name
and then sends the relevant email.
CODE
Option Explicit
'~~> To Field in Email
Const strTo As String = "aaa#aaa.com"
'~~> CC field in email. If you do not want to CC then change "bbb#bbb.com" to ""
Const strCC As String = "bbb#bbb.com"
'~~> This is what goes in the body
Const strBody1 As String = "Dear XYZ,"
Const strBody2 As String = "This is in reference to leave request for employee "
Const strBodyApp As String = "The employee has sufficient leave balance and can take the leave"
Const strBodyNotApp As String = "The employee doesn't have sufficient leave balance and hence cannot take the leave"
Const strByeBye As String = "Thanks and Regards"
Const sender As String = "ABC"
Sub Sample()
Dim ws As Worksheet
Dim aCell As Range
Dim Ret
Dim Bal As Long
Dim Rw As Long
Ret = Application.InputBox("Please enter the name of the employee who wants to take a leave")
If Ret = "" Then Exit Sub
Set ws = Sheets("Sheet3")
Set aCell = ws.Columns(2).Find(What:=Ret, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Bal = aCell.Offset(, 5).Value
Rw = aCell.Row
If Bal > 0 Then
Approved Ret, True, Rw
Else
Approved Ret, False, Rw
End If
Else
MsgBox "The employee " & Ret & " was not found"
End If
End Sub
Sub Approved(EmpName, app As Boolean, lRow As Long)
Dim msg As String
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
If app = True Then
msg = "<p class=MsoNormal>" & strBody1 & "<o:p></o:p></p>" & vbNewLine & _
"<p class=MsoNormal><o:p> </o:p></p>" & vbNewLine & _
"<p class=MsoNormal>" & strBody2 & EmpName & ". " & strBodyApp & _
"<span style='mso-fareast-font-family:""Times New Roman""'><o:p></o:p></span></p>"
Else
msg = "<p class=MsoNormal>" & strBody1 & "<o:p></o:p></p>" & vbNewLine & _
"<p class=MsoNormal><o:p> </o:p></p>" & vbNewLine & _
"<p class=MsoNormal>" & strBody2 & EmpName & ". " & strBodyNotApp & _
"<span style='mso-fareast-font-family:""Times New Roman""'><o:p></o:p></span></p>"
End If
Set rng = Sheets("Sheet3").Range("A1:F1" & ",A" & lRow & ":F" & lRow)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = strTo
.CC = strCC
.BCC = ""
.Subject = "Leave Status"
.HTMLBody = msg & _
RangetoHTML(rng) & _
"<p class=MsoNormal><span style='mso-fareast-font-family:""Times New Roman""'>" & strByeBye & "<o:p></o:p></span></p>" & _
"<p class=MsoNormal><span style='mso-fareast-font-family:""Times New Roman""'><o:p> </o:p></span></p>" & _
"<p class=MsoNormal><span style='mso-fareast-font-family:""Times New Roman""'>" & sender & "<o:p></o:p></span></p>"
.Display '.Send 'To send the email
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
'~~> Taken from http://www.rondebruin.nl/mail/folder3/mail4.htm
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
fileName:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
DISCLAIMER: Since the above code is a basic example, I have not
1) included Error handling (which you should)
2) used basic stuff as Application.ScreenUpdating
SAMPLE FILE: This link will be active for the next 7 days. I have uploaded a sample file for you to play with :)
http://wikisend.com/download/562482/Sample.xls
HTH