Sending Birthday Greetings via Email using list of addresses in Excel Sheet

[kcscdf]

I have done up a method (that works without considering the weeknumber) to send out emails to a list of addresses through outlook. See Below:

[VBA]
Sub SendWithAtt()
Dim olApp As Outlook.Application
Dim olMail As MailItem

Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)


ActiveWorkbook.Save

Dim n As Integer
Dim Recip As String
n = 2
Recip = ""
Do Until Cells(n, 4) = ""
Recip = Recip & ";" & Cells(n, 4)
n = n + 1
Loop

With olMail
.BCC = Recip
.Subject = "BagAge Promotions and News!"
.Display
End With
Set olMail = Nothing
Set olApp = Nothing


End Sub
[/VBA]


Okie, right now. i am trying to create another method that looks through the weeknumber in the excel sheet and obtain only those addresses that matches the weeknumber of say today. But i am having problem trying to get the addresses into the mail window(it pops up but does not fill up the BCC list). The email addresses are filled in the column before the weeknumber, thats why i did an activeoffset(0,-1)..

If anyone knows this please help me! Thanks. See below

[VBA]
Sub SendSpecial()

Dim c As Range, Week As Integer, Recip As String
Dim today As Integer, email As String

today = Range("G1")

For Each c In Range("weeknumber")
Range("c").Select
If c = today Then
ActiveCell.Offset(0, -1).Range("A1").Select
email = Selection.Text
Recip = email & ";" & Recip
End If
Next c

Dim olApp As Outlook.Application
Dim olMail As MailItem
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)

With olMail
.BCC = Recip
.Subject = "Birthday Greetings from BagAge!"
.Display
End With
Set olMail = Nothing
Set olApp = Nothing

End Sub
[/VBA]

[GTO]

Greetings KC,

I see that this is your first post and you just joined. As a fairly recent member, let me say 'Welcome' and a 'Howdy' from Arizona! Hopefully not too much of a brag on the forum, but you will 'meet' some great folks here, who will go out of their way to help you help you :-)

Anyways, as to your problem: in looking at your code, the error I saw was in the For Each:
[vba]For Each c In Range("weeknumber")
'//This//
'Range("c").Select
'//should be//
c.Select
'...etc
[/vba]

The other things I noted were that you are using .Select and Selection and that the code requires setting a reference to Outlook as it is Early Bound.

In this example, we'll get rid of selecting. As I didn't know where "weeknumber" starts or ends, I guessed reference your original code and placed the dates of birth in E2 thru the last used row in E. I'm afraid I also wasn't sure of what 'today' referred to, but am guessing that it might be the current week of the year (1-52).

Anyways, let's presume that G2 holds TODAY(), and that this will be compared to dates of birth in column E. This way, we don't have to figure what week of the year the customer/employee/friend was born in. While there's probably a niftier way of doing this, see if this helps:

In a standard module:
[vba]Option Explicit

Sub SendSpecial_v2()
Dim wksContacts As Worksheet
Dim dtmStartWeek As Date
Dim dtmEndWeek As Date
Dim lngLastRow As Long
Dim rngBirthdates As Range
Dim rngCell As Range
Dim strRecipient As String
Dim olApp As Outlook.Application
Dim olMail As MailItem

'// Presumes the sheet is named "Contacts", change to suit //
Set wksContacts = ThisWorkbook.Worksheets("Contacts")

With wksContacts

'// we'll use a function to determine the start and end of the current week. //
dtmStartWeek = WeekParameter(.Range("G2"), Start:=True, FirstDayOfWeek:=vbSunday)
dtmEndWeek = WeekParameter(.Range("G2"), Start:=False, FirstDayOfWeek:=vbSunday)

'// substitute for not knowing where "weeknumber" is //
lngLastRow = .Cells(Rows.Count, 5).End(xlUp).Row

'// This could be changed to the defined range "weeknumber" //
Set rngBirthdates = .Range("E2:E" & lngLastRow)

For Each rngCell In rngBirthdates
'// Coerce a date using the current year and the customer's month and day //
'// of birth and compare this to the start and end of the current week to //
'// see if we should send them a Happy B-Day msg //
If DateSerial(Year(.Range("G2")), _
Month(rngCell), _
Day(rngCell)) >= dtmStartWeek _
And DateSerial(Year(.Range("G2")), _
Month(rngCell), _
Day(rngCell)) <= dtmEndWeek Then

'// Build our address string //
strRecipient = strRecipient & rngCell.Offset(, -1).Value & "; "
End If
Next

'// strip the last semi-colon and space //
strRecipient = Left(strRecipient, Len(strRecipient) - 2)
End With

'// Create the msg as you were doing //
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)

With olMail
.BCC = strRecipient
.Subject = "Birthday Greetings from BagAge!"
.Display
End With

Set olMail = Nothing
Set olApp = Nothing
End Sub

Function WeekParameter(dat As Date, _
Optional Start As Boolean = True, _
Optional FirstDayOfWeek As VbDayOfWeek = vbSunday) As Date
Dim lngWeekday As Long

lngWeekday = Weekday(dat, FirstDayOfWeek)

If Start Then
If lngWeekday = 1 Then
WeekParameter = dat
Else
WeekParameter = dat - (lngWeekday - 1)
End If
Else
If lngWeekday = 7 Then
WeekParameter = dat
Else
WeekParameter = dat + (7 - lngWeekday)
End If
End If
End Function[/vba]

Hope this helps,

Mark

[kcscdf]

Wow, Thanks Mark for the effort all the way from the USA! Actually after i posted this, i went on to figure out another way of doing it, but i have to include the weeknum column in the excel file though. See below

[VBA]
Sub SendSpecial()
Dim c As Range, Week As Integer, Recip As String
Dim today As Integer, email As String, n As Integer
today = Range("G1")
n = 2
Recip = ""
Do Until Cells(n, 5) = ""
If today = Cells(n, 5) Then
Recip = Recip & ";" & Cells(n, 4)
Else
End If
n = n + 1
Loop
Dim olApp As Outlook.Application
Dim olMail As MailItem
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.BCC = Recip
.Subject = "Birthday Greetings from BagAge!"
.Display
End With
Set olMail = Nothing
Set olApp = Nothing

End Sub
[/VBA]
Works perfectly fine for me also, but i will try your method too. It's definitely a much better code. Will see how it fits! Thank you again

[GTO]

You are most welcome :-)

If solved, there is a Mark Solved button under Thread Tools right above your first post. This helps save folks time in preventing checking threads already solved.

Have a great day,

Mark