If then conditions and post to specific e-mail using VBA Excel

S

sheenu

New member
Joined
Aug 15, 2013
Messages
6
Reaction score
0
Points
0
Please check the attachment and suggest a solution(code).

The logic is

When the difference between Column G (Date Shipped) and Col. H (Response Date) is more than 15 days, the cell range of that row must be sent to the corresponding e-mail in that row.

For instance, information from B3:F3 gets delivered to the specific e-mail address in I3 column if the difference is found to be true.

I am using Excel 2007 and Outlook 2007.


Please suggest a solution. I would really appreciate your help. I am very new to VBA.

Thanks
Sheenu
 
Hi, I've searched Ron de Bruin website and find the info for e-mailing the address from the cell.

The only problem is to set a condition for this.

I've also attached the link for reference i.e Student's example

www(dot)rondebruin(dot)nl/win/s1/outlook/bmail8.htm
 
Adapted from Ron de Bruin's site:
run emailIt with the relevant sheet active:
Code: 
Sub emailIt()
For Each rw In Range("A3").CurrentRegion.Rows
  If rw.Cells(8).Value - rw.Cells(7).Value > 15 Then
    Mail_Selection_Range_Outlook_Body rw.Resize(, 8)
  End If
Next rw
End Sub
Sub Mail_Selection_Range_Outlook_Body(myRng As Range)
'For Tips see: dot rondebruin dot nl/win/winmail/Outlook/tips dot htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
Set rng = myRng
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")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
  .To = myRng.Offset(, 8).Resize(, 1).Value
  .CC = ""
  .BCC = ""
  .Subject = "This is the Subject line"
  .HTMLBody = RangetoHTML(rng)
  
  .display 'or use .Send
End With
On Error GoTo 0

With Application
  .EnableEvents = True
  .ScreenUpdating = True
End With

Set OutMail = Nothing
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
 
Thanks p45cal for helping out.

But it is not running. It gives me an error saying 'Type mismatch'
 
sheenu said:
Thanks p45cal for helping out.

But it is not running. It gives me an error saying 'Type mismatch'
Click to expand...
on what line is the yellow highlight when you choose Debug?, or what is selected when the code refuses to run?
See attached which works here fine.
 

Attachments

  • If Then e-mail Vba excelguru2033.xlsm
    22.9 KB · Views: 80
p45cal said:
on what line is the yellow highlight when you choose Debug?, or what is selected when the code refuses to run?
See attached which works here fine.
Click to expand...

Thanks a lot. It is working now. You're an angel.

Human desire would never be satisfied. So, here goes my next question.

I also want to include the headers with the rows, a message and my signature in the body of the mail.

Please check.
 
In the same file:
Code: 
Sub emailIt()
For Each rw In Range("A3").CurrentRegion.Rows
  If rw.Cells(8).Value - rw.Cells(7).Value > 15 Then
    Mail_Selection_Range_Outlook_Body Union(Range("A1").Resize(, 8), rw.Resize(, 8))
  End If
Next rw
End Sub
Sub Mail_Selection_Range_Outlook_Body(myRng As Range)
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
Set rng = myRng
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")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
  .To = myRng.Areas(2).Offset(, 8).Resize(, 1).Value
  .CC = ""
  .BCC = ""
  .Subject = "This is the Subject line"
  strbody = "Dear Customer,<br><br>Please deal with this asap.<br>Let me know if you have problems.<br>"

  zz = RangetoHTML(rng)
  .display
  y = .htmlbody
  .htmlbody = strbody & zz & y  'myhtmlbody
End With
On Error GoTo 0

With Application
  .EnableEvents = True
  .ScreenUpdating = True
End With

Set OutMail = Nothing
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
 
You must log in or register to reply here.
Back
Top