Please help me get time back with my kids.

[Vampyredh]

Hello all,

I am new to the wonderful world of visual basic, and I have been having some issues trying to get something to work for me and was hoping on of you may be able to assist me. I got into Visual Basic because I do a lot of emailing based on an excel report I get daily from my company. The report contains many rows of assignments that are due.

I have to read this report check dates in column E against today's date - 5 days, so if the date in column E is less than 5 days from the current date, I have check column F to see if there is an #N/A, if there is I am to send the Person involved in an email. There name can be found in column G. The email is to contain the id number and company name in the subject line which the id can be found in column A and the company in column Z. I have tried numerous forums and threads over the last week looking for help. I am generating 30 to 40 emails per day based on this excel spread sheet. I know that automation is the answer to saving me many hours (I am paid a pittance for pay working 60 plus hours a week 20 of it is spent sending this email) I have included a base example of the workbook no formatting mostly for a visual reference. If any of you could help me out with a visual basic macro to do this for me I would be very humbled as my kids would get to see me a little more. I would even be fine if it created a new word doc that would have this info that I need if an email is not possible.

 

[Eric W]

What you're asking seems very possible. As always, it depends on the details, especially since your example did not come through. I built a sample sheet like this:

	A	B	C	D	E	F	G	H	Y	Z
1	1001				2/25/2016		Amy			Company 1
2	2002				1/1/2016		Beth			Company 2
3	3003				3/25/2016	#N/A	Cal			Company 3
4

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet2​

I assumed that your email program is Outlook. If not, then we'll probably just have to create an extract file. If this matches your spreadsheet, follow these steps:

1) Open the spreadsheet
2) Right click on the sheet tab on the bottom and select View Code
3) Paste the following code:

Sub MailLoop()
Dim r As Long, oMail As Object, oApp As Object

    'Create and show the outlook mail item
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    
    For r = 1 to Columns("G").End(xlDown).Row
        If Abs(Date - Cells(r, "E")) < 5 And IsError(Cells(r, "F")) Then
            With oMail
                .to = Cells(r, "G")
                .Subject = Cells(r, "A") & " / " & Cells(r, "Z")
                '.cc = ""
                '.bcc = ""
                .Body = "Action required"
                '.Attachments.Add WB.FullName
                .Display
                Stop
                
                '.Send
            End With
        End If
    Next r
    
     'Release Outlook
    Set oMail = Nothing
    Set oApp = Nothing
    
End Sub

4) Press F5 to run it. It will search out lines matching the criteria you cited, create an email based on the information on that line, and pause. You can then finish filling out the email, send it, then press F5 again to continue searching for the next one. If all the required information is in the email already, then you can comment out the .Display and Stop lines (put a single quote at the start of the line, see the other examples) and remove the single quote from the .Send line, and all the emails will be sent automatically.

Let me know if this helps.

 

[Vampyredh]

I did try your macro and it gave me a type mismatch as soon as it started the if statement. Thank you for your help.

 

[Eric W]

It appears that the date is stored as a text value, not a date (numeric) value. If so, then you can convert it to a date like this:

Sub MailLoop()
Dim r As Long, oMail As Object, oApp As Object, MyDate As Date

    'Create and show the outlook mail item
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    
    For r = 1 To Columns("G").End(xlDown).Row
        MyDate = DateValue(Cells(r, "E"))
        If Abs(Date - MyDate) < 5 And IsError(Cells(r, "F")) Then
            With oMail
                .to = Cells(r, "G")
                .Subject = Cells(r, "A") & " / " & Cells(r, "Z")
                '.cc = ""
                '.bcc = ""
                .Body = "Action required"
                '.Attachments.Add WB.FullName
                .Display
                Stop
                
                '.Send
            End With
        End If
    Next r
    
     'Release Outlook
    Set oMail = Nothing
    Set oApp = Nothing
    
End Sub

 

[Vampyredh]

I really appreciate such a quick response. When I run the code this time I get a new error.


Run-time error '13':
Type mismatch

MyDate = DateValue(Cells(r, "E")) is highlighted yellow in the debug

I am so bare minimum when it comes to this That I have no idea why.

 

[Vampyredh]

I'm not sure how to post attachments on this forum. But I took screen shots of the error.

 

[MandeepBaluja]

Change [COLOR=#333333]For r = 2 to Columns("G").End(xlDown).Row[/COLOR]

 

[Vampyredh]

Ok that time it did not crash but is there a way to leave the email open so I can make adjustments. I know that there may be 30 emails open at the same time. I'm ok with that. But I may need to add extra information to the email. After checking my outlook I see no drafts no sent, no type of email at all.

 

[Eric W]

Try this: (thanks for the assist MandeepBaluja),

This should create an unsent email for each matching line.

Sub MailLoop2()
Dim r As Long, oApp As Object, MyDate as Date

    'Create and show the outlook mail item
    Set oApp = CreateObject("Outlook.Application")
    
    For r = 2 To Columns("G").End(xlDown).Row
        MyDate = DateValue(Cells(r, "E"))
        If Abs(Date - MyDate) < 5 And IsError(Cells(r, "F")) Then
            With oApp.CreateItem(0)
                .To = Cells(r, "G")
                .Subject = Cells(r, "A") & " / " & Cells(r, "Z")
                .Body = "Action required"
                .Display
                
                '.Send
            End With
        End If
    Next r
    
     'Release Outlook
    Set oApp = Nothing
    
End Sub

 

[Vampyredh]

Not seeing a new email or anything in drafts when running it.