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]

 

[Worf]

Re: Help Modifying Code to Send E-mail

This example does it without writing to the worksheet:

' Excel module
Sub mail()
Dim myitem As MailItem, olapp, xdoc As Word.Document, stext$, _
odata As New DataObject, col%, i%, r As Range, j%, k%
Set r = [a1:f15]                                                ' original range
col = r.Columns(1).Column + r.Columns.Count
Range(Cells(r.Rows(1).Row, col), Cells(r.Rows(r.Rows.Count).Row, col)).FormulaR1C1 = _
"=COUNTA(RC[-" & r.Columns.Count & "]:RC[-1])"
Set r = r.Resize(r.Rows.Count, r.Columns.Count + 1)
ActiveSheet.AutoFilterMode = 0
r.AutoFilter r.Columns.Count, ">0"
Set r = r.SpecialCells(xlCellTypeVisible)
ActiveSheet.AutoFilterMode = 0
stext = ""
For i = 1 To r.Areas.Count                                      ' build string
    For k = 1 To r.Areas(i).Rows.Count
        For j = 1 To r.Areas(i).Columns.Count - 1
            stext = stext & r.Areas(i).Cells(k, j) & vbTab
        Next
        stext = stext & vbCrLf
    Next
Next
Set olapp = CreateObject("Outlook.Application")
Set myitem = olapp.CreateItem(olMailItem)
With myitem
    .To = "sdaphne@fan.net"
    .Subject = "Umbrellas"
    .Body = " "
    .Display
End With
odata.SetText stext
odata.PutInClipboard
Set xdoc = myitem.GetInspector.WordEditor
xdoc.Parent.Selection.HomeKey wdStory
xdoc.Parent.Selection.Paste                                     ' into Outlook
Set myitem = Nothing
Set olapp = Nothing
End Sub

 

[Justinian]

Re: Help Modifying Code to Send E-mail

I got a compile error on "myitem as Mailitem." I thought I just needed something like changing my range of A1:F30 to [FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Range("A" & Rows.Count).End(xlUp).Row?[/FONT]

 

[Worf]

Re: Help Modifying Code to Send E-mail

• At the Excel VBE, add a reference to the Microsoft Outlook xx Object Library.
• My code removes blank rows in the middle of the data; if your range is a single block, finding the last used row is enough. What is your scenario?

 

[Justinian]

Re: Help Modifying Code to Send E-mail

I should have shared my files in the first place. The link below is how my data looks after I paste into Excel from an external database:

https://app.box.com/s/zomeqtnvusdn0t4kqhhlh2s35cpn3r43

What I end up doing is separating this file by putting a blank row in between each date and then copying the data set to an e-mail. When you open the file, you will see 7/16, 7/17, and 7/18 together in one block. When I send the report, it should look like this:

​

​https://app.box.com/s/7lxza5grt9u1ng5hq4gezl81d142ls2g

_{^{<strike>
</strike>}}

 

[Worf]

Re: Help Modifying Code to Send E-mail

​The second link is not working for me. I am giving you my email on a PM so you can send it to me.

 

[Worf]

Re: Help Modifying Code to Send E-mail

Questions:

Do you want the code to insert the blank rows?
I understand that after the dates are separated, all the range has to be transferred to a single email, is this correct?

 

[Justinian]

Re: Help Modifying Code to Send E-mail

Yes, if you know how to alter the code to separate dates. The report is for the current day (7/19 for example) plus the next two days. So every day when I run this report, only three dates should be listed, each separated by a blank row. So I just need code to recognize the three different dates and separate them with a blank row.

Once the separation of dates occurs, I just want to copy that data so I can paste it into a blank e-mail and send to my supervisor.

 

[Worf]

Re: Help Modifying Code to Send E-mail

The following code separates the dates; I will be back later with the email part.

Dim lr%
Sub main()
Dim a(1 To 2), i%
lr = Range("e" & Rows.Count).End(xlUp).Row
Range("g2:g" & lr).Formula = "=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("=LOOKUP(2,1/($E$2:$E$" & lr & "=" & (a(i)) & "),$G$2:$G$" _
    & lr & ")") + 1, 5).EntireRow.Insert
Next
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

Thank you.

 

[Worf]

Re: Help Modifying Code to Send E-mail

The previous code is not very good, as it uses a helper column, this one is better:

Sub main2()
Dim a(1 To 2), i%
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
End Sub