Modifying Code to Send E-mail

Justinian

Well-known Member
Joined
Aug 9, 2009
Messages
1,551
Office Version
  1. 365
Platform
  1. Windows
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]
 
Re: Help Modifying Code to Send E-mail

This example does it without writing to the worksheet:

Code:
' 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
 
Upvote 0

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
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]
 
Upvote 0
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?
 
Upvote 0
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>
 
Last edited:
Upvote 0
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.
 
Upvote 0
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?
 
Upvote 0
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.
 
Upvote 0
Re: Help Modifying Code to Send E-mail

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


Code:
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
 
Upvote 0
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:

Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,236
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top