Modifying Code to Send E-mail

[Justinian]

I have a daily report I need to send to my manager. Right now, my report has code to copy A1:F30 so I can paste the data into an e-mail. How do I modify this code so that I only copy rows with data instead of A1:F30?

[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Send_Email()
On Error Resume Next
Dim OutApp As Object
Dim OutMail As Object
Dim objNsp As Object
Dim colSyc As Object
Dim objSyc As Object
Dim i As Integer[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif] Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set objNsp = appOL.Application.GetNamespace("MAPI")
Set colSyc = objNsp.SyncObjects[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif] On Error Resume Next
With OutMail
.To = "john.smith@aol.com"
.Subject = "Daily Report - " & Format(Date, "mm/dd/yy")
.Display
' .Display ' to open a mail window with a normal 'SEND' icon available'
' .Send ' to send without displaying mail

Range("A1:F30").Select
Selection.Copy

End With[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif] For i = 1 To colSyc.Count
Set objSyc = colSyc.Item(i)
objSyc.Start
Next[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif] On Error GoTo 0[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Set OutMail = Nothing
Set objNsp = Nothing
Set colSyc = Nothing
Set objSyc = Nothing
Set OutApp = Nothing[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]aa:
End Sub[/FONT][FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
[/FONT]

 

[Justinian]

Re: Help Modifying Code to Send E-mail

Sweet! Thank you for your help!

 

[Justinian]

Re: Help Modifying Code to Send E-mail

What about the code to only copy used rows?

 

[Worf]

Re: Help Modifying Code to Send E-mail

The following code creates a formatted email, is this your desired product?

Dim lr%


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
    Dim fso As Object, ts As Object, TempFile$, TempWB As Workbook
    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 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
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Sub main2() ' run me
Dim a(1 To 2), i%, rng As Range, OutApp As Object, OutMail As Object
lr = Range("e" & Rows.Count).End(xlUp).Row
Sort
a(1) = CDbl(Cells(2, 5))                ' day one
a(2) = CDbl(a(1) + 1)                   ' day two
For i = 1 To 2
    Cells(Evaluate("=sumproduct(max(row($e$2:$e$" & lr & ")*(" & a(i) & _
    "=$e$2:$e$" & lr & ")))") + 1, 5).EntireRow.Insert
Next
Set rng = Range("a1:f" & lr + 2)
Application.EnableEvents = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = "ron@debruin.nl"
    .CC = "carbon@copy.com"
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = RangetoHTML(rng)
    .display
End With
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub


Sub Sort()
With ActiveWorkbook.Worksheets(ActiveSheet.Name).Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("E1:E" & lr), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=0
    .SetRange Range("A1:F" & lr)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = 1
    .Apply
End With
Range("A:A,C:E").EntireColumn.HorizontalAlignment = xlCenter
End Sub

 

[Justinian]

Re: Help Modifying Code to Send E-mail

That is it except I would like the empty rows between dates to be clear of all formatting and for the used cells only in column D (Complete Date) to have a yellow fill. Is that possible?

 

[Worf]

Re: Help Modifying Code to Send E-mail

New version:

Sub main2() ' run me
Dim a(1 To 2), i%, rng As Range, OutApp As Object, om As Object, r%, f$
lr = Range("e" & Rows.Count).End(xlUp).Row
Sort
a(1) = CDbl(Cells(2, 5))                ' day one
a(2) = CDbl(a(1) + 1)                   ' day two
For i = 1 To 2
    r = Evaluate("=sumproduct(max(row($e$2:$e$" & lr & ")*(" & a(i) & _
    "=$e$2:$e$" & lr & ")))") + 1
    Cells(r, 5).EntireRow.Insert
    Cells(r, 5).EntireRow.Clear
Next
Set rng = Range("d2:d" & lr + 2)
f = "=NÚM.CARACT(D2)>0"                     ' Portuguese version
'   f = "=len(d2)>0"                        ' use this one
rng.FormatConditions.Add Type:=xlExpression, Formula1:=f
rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority
With rng.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
    .Color = 6750207                        ' yellow
    .TintAndShade = 0
End With
rng.FormatConditions(1).StopIfTrue = 0
Set rng = Range("a1:f" & lr + 2)
Application.EnableEvents = 0
Set OutApp = CreateObject("Outlook.Application")
Set om = OutApp.CreateItem(0)
With om
    .To = "ron@debruin.nl"
    .CC = "carbon@copy.com"
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = RangetoHTML(rng)
    .display
End With
With Application
    .EnableEvents = True
    .ScreenUpdating = 1
End With
Set om = Nothing
Set OutApp = Nothing
End Sub

 

[Justinian]

Re: Help Modifying Code to Send E-mail

I am getting a compile error: sub or function not definded with this code below:

[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]RangetoHTML(rng)[/FONT]

 

[Worf]

Re: Help Modifying Code to Send E-mail

You can get that function at post 23.

 

[Justinian]

Re: Help Modifying Code to Send E-mail

Now I am getting a compile error: Ambiguous name detected: main2.

 

[keiranwyllie]

Re: Help Modifying Code to Send E-mail

I just came across this and it looks like a great way to automatically share data with other users. I've been working my way through the code but can't quite grasp how I could modify it for my particular case. In the spreadsheet 'Report.xlsm' at the link below, I have a sheet named 'Job Comments' and I'd be keen to achieve a similar result by having that content copied to an email message. I don't require any sorting or blank rows, just the data from Row A to the last row.
Any help or guidance would be greatly appreciated.

https://github.com/keiranwyllie/excel

 

[Worf]

Re: Help Modifying Code to Send E-mail

Justin

You can have only one routine with that name, use the version from post 25.

Keiran

I will work on your request as soon as the OP‘s query is solved.