I have a worksheet with data from column A until column V. The data starts from row 3. I need to filter a column (column 21) with the data = "Pending" and send the data to selected recipients via email. If via manual, I will need to do the following:-
- Select the header which starting from row 3 until the last row
- Select visible cells only
- Copy the header and filtered range (visible cells)
- Go to MS Outlook
- Create New Email
- Subject: Please Enter Email Subject!
- To: xxx@gmail.com (1 people)
- To: aaa@gmail.com, bbb@gmail.com, ccc@gmail.com (many people)
- In the body of the email
- Paste #3 above
- Find and attach the excel file
With macro, below are the codes.
Public Sub SendEmail()
Application.DisplayAlerts = False
Dim objOutlook As Object
Dim objMail As Object
Dim i As Long
Dim rngA as Range
Dim rngB as Range
Dim rng as Range
i = Cells(Rows.Count, "A").End(xlUp).Row
ActiveSheet.Range("$A$4:$V$" & i).AutoFilter Field:=21, Criteria1:="Pending"
Range("A4").Select
Set rngA = ActiveSheet.Range("A3:V3") ''' This is header
Set rngB = ActiveSheet.AutoFilter.Range ''' This is filtered range
Set rng = Application.Union(rngA, rngB) ''' Combine header and filtered range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.Subject = "Please Enter Email Subject!"
''.To = "xxx@gmail.com"
.To = "aaa@gmail.com;bbb@gmail.com;ccc@gmail.com"
.HTMLBody = RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName ''''' To attach current active workbook in email
.Send
End With
Set objOutlook = Nothing
Set objMail = Nothing
''' MsgBox "Done!" -- if needed
End Sub
Function RangetoHTML(rng As Range)
Application.DisplayAlerts = False
Dim fso As Object ''' fso = File System Object
Dim ts As Object ''' ts = TextStream
Dim TempFile As String
Dim TempWB As Workbook
Dim r As Long
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial xlPasteColumnWidths
.Cells(1).PasteSpecial
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
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
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
No comments:
Post a Comment