Results 1 to 10 of 10

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

  1. #1

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



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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

  2. #2
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,479
    Articles
    0
    Excel Version
    365
    Quote Originally Posted by sheenu View Post
    Please check the attachment
    attachment?!

  3. #3
    If Then e-mail Vba.xlsx

    Sorry for that, p45cal.

    I've attached the file this time.
    Attached Thumbnails Attached Thumbnails Click image for larger version. 

Name:	if then.png 
Views:	34 
Size:	36.3 KB 
ID:	1589  

  4. #4
    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

  5. #5
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,479
    Articles
    0
    Excel Version
    365
    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

  6. #6
    Thanks p45cal for helping out.

    But it is not running. It gives me an error saying 'Type mismatch'

  7. #7
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,479
    Articles
    0
    Excel Version
    365
    Quote Originally Posted by sheenu View Post
    Thanks p45cal for helping out.

    But it is not running. It gives me an error saying 'Type mismatch'
    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.
    Attached Files Attached Files

  8. #8

    Smile

    Quote Originally Posted by p45cal View Post
    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.
    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.

  9. #9
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,479
    Articles
    0
    Excel Version
    365
    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

  10. #10
    i have no words to thank you, p45cal.

    Regards

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •