So I built a code that works for mailing 1 list (in Column A): Cell A1 has a region, Cells A2 though last row have an email address that needs that email. This code works fine for column A. But if a made a list in Columns B-#( however many number of columns), could i add onto this code and make it create as many emails as there are columns, and send them to the list of people below row 2.
In other words, can we make this say for Each column with a value in the first row create and email and send it to everyone else below it?
thanks
Sub emailfromcolumns()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim LastRow As Long
Dim Namelist As String
LastRow = Range("A" & rows.Count).End(xlUp).Row
'email recipients are in row 2 to the last row
For i = 2 To LastRow
If Sheets("Recipients").Range("A2").Value <> "" Then
Namelist = Namelist & ";" & Sheets("Recipients").Range("A" & i).Value
End If
Next
MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
& "<li>Please let me know if there is anything else you need or any changes you would like to see.<br><br>" _
& "<li>Thanks,<br><br>" _
& "Thank you, Pricing Team<br><br>" _
Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject(Class:="outlook.application")
End If
Set olMail = olApp.CreateItem(0)
With olMail
.To = Namelist
.Subject = Range("A1").Value & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.display
.HTMLBody = MailMessage
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Range("A1").Value & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
.Save
.Close 1
End With
Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True
End Sub
I would make your existing routine accept a column number so you can pass any column to it, and then it will work for that column e.g.
Sub emailfromcolumns(COL As Long)
So then you can just call emailfromcolumns(1) to email for column A, emailfromcolumns(2) to email for column B etc.
Then you can create a second sub routine that finds out how many columns there are and just loops through them all, calling your existing routine:
Sub loopit()
Dim lastColumn As Long
Dim x As Long
lastColumn = Sheets("Recipients").Cells(1, Sheets("Recipients").Columns.Count).End(xlToLeft).Column
For x = 1 To lastColumn
emailfromcolumns (x)
Next x
End Sub
This means all you have to do to your existing code is replace any reference to column "A" with the variable COL - there are four lines:
change
LastRow = Range("A" & rows.Count).End(xlUp).Row
to
LastRow = Cells(Rows.Count, COL).End(xlUp).Row
change
If Sheets("Recipients").Range("A2").Value <> "" Then
Namelist = Namelist & ";" & Sheets("Recipients").Range("A" & i).Value
End If
to
If Cells(2, COL).Value2 <> "" Then
Namelist = Namelist & ";" & Cells(i, COL).Value2
End If
and the last two lines are within the e-mail bit:
.Subject = Sheets("Recipients").Cells(i, COL).Value2 & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Sheets("Recipients").Cells(i, COL).Value2 & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
On top of this, your code has some risky sections where you're just referring to Range without declaring which sheet the range is on... below is full version tidied up with comments on the differences:
Sub emailfromcolumns(COL As Long)
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim LastRow As Long
Dim Namelist As String
Dim WS As Worksheet ' Declare a worksheet object
Set WS = ThisWorkbook.Worksheets("Recipients") ' set the worksheet object WS to "Recipients" for easy reference
LastRow = WS.Cells(WS.Rows.Count, COL).End(xlUp).Row ' last row now definitely referencing "Recipients" thanks to WS
'email recipients are in row 2 to the last row
' changed your "A2" check to outside the loop, don't need to check it each time
If WS.Cells(2, COL).Value2 <> "" Then
For i = 2 To LastRow
Namelist = Namelist & ";" & WS.Cells(i, COL).Value2
Next i
End If
MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
& "<li>Please let me know if there is anything else you need or any changes you would like to see.<br><br>" _
& "<li>Thanks,<br><br>" _
& "Thank you, Pricing Team<br><br>" _
Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then Set olApp = CreateObject(Class:="outlook.application")
Set olMail = olApp.CreateItem(0)
With olMail
.To = Namelist
.Subject = WS.Cells(1, COL).Value2 & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.display
.HTMLBody = MailMessage
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & WS.Cells(1, COL).Value2 & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
.Save
.Close 1
End With
Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True ' You didn't have anywhere that says Application.ScreenUpdating = False ?
End Sub
Sub emailfromcolumns()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim MailMessage As String
Dim i As Long
Dim z As Long
Dim LastRow As Long
Dim Namelist As String
Dim colCount As Long
'How Many Columns?
colCount = 4
'Loop through columns
For z = 1 To colCount
'email recipients are in row 2 to the last row
Namelist = vbNullString
With Worksheets("Recipients")
LastRow = .Cells(.Rows.Count, z).End(xlUp).Row
For i = 2 To LastRow
If .Cells(i, z).Value <> "" Then
Namelist = Namelist & ";" & .Cells(i, z).Value
End If
Next
End With
'Only create message if emails exist?
If Len(Namelist) > 0 Then
MailMessage = "<HTML><BODY> Good Afternoon All, <br><br>" _
& "<li>Please let me know if there is anything else you need or any changes you would like to see.<br> " _
& "<br>" _
& "<li>Thanks,<br><br>" _
& "Thank you, Pricing Team<br><br>" _
Set olApp = GetObject(Class:="Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject(Class:="outlook.application")
End If
Set olMail = olApp.CreateItem(0)
With olMail
.To = Namelist
.Subject = Sheets("Recipients").Cells(1, z).Value & " 60 Day Expiration " & Format(MonthName(Month(Now)))
.display
.HTMLBody = MailMessage
.Attachments.Add ("C:\Desktop\60 Day Exp\Savefiles\" & Sheets("Recipients").Cells(1, z).Value & " 60 Day Expirations " & Format(MonthName(Month(Now))) & ".xlsx")
.Save
.Close 1
End With
Set olMail = Nothing
Set olApp = Nothing
End If
Next z
Application.ScreenUpdating = True
End Sub
Related
I'm attempting to send an email for each attendance event that is being displayed within the Pivot Table. Though it will recognize the count of rows, only the 1st row is being sent in email up to as many emails as there are rows of data.
I believe I need my offset parameters to change so it's changing by row & cell. Any suggestions?
enter image description here
Sub EmailBody()
Application.ScreenUpdating = False
ThisWorkbook.RefreshAll
'Tells it to re-run every x hours and min.
Application.OnTime Now + TimeValue("1:00"), "EmailBody"
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
Dim arrHolidays As Variant, iDay As Variant
arrHolidays = Application.Transpose(Worksheets("Hold").Range("a:a").Value) 'Add all your holidays on Holidays worksheet
For Each iDay In arrHolidays
If Date = iDay Then Exit Sub 'exit this sub if date is a holiday
Next
On Error Resume Next
ThisWorkbook.RefreshAll
Worksheets("Sheet1").Activate
'Creating references to Application and MailItem Objects of Outlook
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
'Creating variable to hold values of different items of mail
Dim sendTo, MailBody As String
Dim lstRow As Long
ThisWorkbook.Sheets("Sheet1").Activate
'Getting last row of containing email id.
lstRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim rng As Range
Set rng = Range("B2:B" & lstRow)
'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.
For Each i In Range("b2:b100")
MailBody = "Please see the following attendance event logged in SharePoint for " & i.Offset(0, -1) & "." & vbCr & vbCr & "Date of Absence " & " : " & i.Offset(0, 2) & vbCr & "Reason for Absence " & " : " & i.Offset(0, 3) & vbCr & "Ticket Entered on" & " : " & i.Offset(0, 4) & vbCr & "Created By" & " : " & i.Offset(0, 5) & vbCr & "Notes" & " : " & i.Offset(0, 6) & vbCr & vbCr & "Please reach out to DLWESTCCWALKERRETENTIONREPORTING#charter.com, if you have any questions."
For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2 & ";" & Range(cell.Address).Offset(0, 1).Value2
Subj = "Attendance Callout Event Notification"
Msg = MailBody
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.Body = Msg
.Subject = Subj
.Display '
.Send
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends
cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True
Next
End Sub
Trying to reference a dynamic range in the body of an email (this will change based on the user's input into the sheet). The email outputs just fine, but there is nothing in the email where "AFund" is supposed to be. Code is below, any help is appreciated!
Dim BlasEmail As Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim FundAdd, FundRem, Broker As Range
Dim AFund As String
Set BlastEmail = ActiveWorkbook
Set Cover = ThisWorkbook.Sheets("Cover")
Set CDEA = ThisWorkbook.Sheets("CDEA")
LastRow = Cells(Rows.Count, 5).End(xlUp).Row
LRow = Cells(Rows.Count, 7).End(xlUp).Row
LasRow = Cells(Rows.Count, 2).End(xlUp).Row
FundAdd = AFund
Set FundAdd = Range("E2:E" & LastRow)
Set FundRem = Range("G2:G" & LRow)
Set Broker = Range("C6:C" & LasRow)
If Range("ISDAMRA") = "ISDA" And Range("G2") = "" Then
Application.ReferenceStyle = xlA1
SigString = Environ("appdata") & _
"\Microsoft\Signatures\My Signature.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
Set OutApp = CreateObject("Outlook.Application")
Dim EmBody As String
EmBody = "Hello," & "<br><br>" & _
"Body goes here " & "<br>" & "<br>" & AFund
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "myemail"
.CC = ""
.BCC = ""
.Subject = "Here is the subject " & Range("B6") & " "
.HTMLBody = EmBody & Signature
'You can add files like this
'.Attachments.Add ("C:\test.txt")
'.Send
.Display 'This will display the emails for the user to review CXH
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'
End Sub
From:
Sending a range of cells...
2 Methods to Quickly Send Selected Cells in an Excel Worksheet as an Outlook Email
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub SendRange()
' https://www.datanumen.com/blogs/2-methods-quickly-send-selected-cells-excel-worksheet-outlook-email/
' https://stackoverflow.com/questions/73136067
Application.Calculation = xlCalculationManual
' Application is Excel. No influence in Outlook.
Application.ScreenUpdating = False
' Reference Microsoft Outlook nn.n Object Library
Dim olApp As Outlook.Application
Dim olEmail As Outlook.MailItem
Dim olInsp As Outlook.Inspector
' Reference Microsoft Word nn.n Object Library
Dim wdDoc As Word.Document
Dim strGreeting As String
Dim lastRow As Long
lastRow = Cells(Rows.Count, 5).End(xlUp).Row
Debug.Print lastRow
Dim fundAdd As Range
Dim objSelection As Range
Set fundAdd = Range("E2:E" & lastRow)
fundAdd.Select
Set objSelection = Selection
objSelection.Copy
Dim objTempWorkbook As Workbook
Set objTempWorkbook = Workbooks.Add(1)
Dim objTempWorksheet As Worksheet
Set objTempWorksheet = objTempWorkbook.Sheets(1)
Dim strTempHTMLFile As String, Strbody As String
Dim objTempHTMLFile As Object, objTextStream As Object
Dim objFileSystem As Object
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
'Pasting into a Temp Worksheet
With objTempWorksheet.Cells(1)
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
'Save the Temp Worksheet as a HTML File
strTempHTMLFile = objFileSystem.GetSpecialFolder(2).Path & _
"\Temp for Excel" & Format(Now, "YYYY-MM-DD hh-mm-ss") & ".htm"
Set objTempHTMLFile = objTempWorkbook.PublishObjects.Add(xlSourceRange, _
strTempHTMLFile, objTempWorksheet.Name, objTempWorksheet.UsedRange.Address)
objTempHTMLFile.Publish (True)
strGreeting = "Hello," & vbNewLine & vbNewLine & _
"Body goes here " & vbNewLine & vbNewLine
Set olApp = New Outlook.Application
Set olEmail = olApp.CreateItem(olMailItem)
With olEmail
Set olInsp = .GetInspector ' A side effect is to get the signature
Set wdDoc = olInsp.WordEditor
wdDoc.Range.InsertBefore strGreeting
wdDoc.Paragraphs(5).Range.Paste
'Insert the Temp Worksheet into the Email Body
Dim wb1 As Workbook
Set wb1 = ActiveWorkbook
Dim TempFilePath As String
TempFilePath = Environ$("temp") & "\"
Dim TempFileName As String
TempFileName = "Output Data"
Dim FileExtStr As String
FileExtStr = ".xlsx"
Debug.Print TempFilePath & TempFileName
wb1.SaveAs TempFilePath & TempFileName, FileFormat:=xlOpenXMLWorkbook
.Display
End With
objTempWorkbook.Close (False)
objFileSystem.DeleteFile (strTempHTMLFile)
Kill TempFilePath & TempFileName & FileExtStr 'Delete the temp Excel File
Set olApp = Nothing
Set olEmail = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I am creating a macro to get email by subject and received date in our team shared box.
I use for loop to check all email in mailbox but it takes forever because my statement checks 1000+ mails.
How can I get email by specific date? Let's say I need email 12/1/2017 to 12/30/2017.
The key is using Restrict method but I don't know how I can use it.
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Dim olShareName As Outlook.Recipient
Set olShareName = OutlookNamespace.CreateRecipient("sharemailbox#example.ca")
Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox).Folders("sharebox subfolder").Folders("sharebox subfolder2")
i = 1
For Each OutlookMail In Folder.Items
If ((Range("From_Date").Value <= OutlookMail.ReceivedTime) And _
(OutlookMail.ReceivedTime <= Range("To_Date").Value)) And _
OutlookMail.Sender = "sender#example.com" Then
Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
i = i + 1
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
I assume the code I have to fix is:
<For Each OutlookMail In Folder.Items>
How can I make statement using Restrict Method?
You could probably use the GetTable instead of a loop which has to process each email (or item) one by one.
GetTable will allow you to apply a filter on the content of the folder which should operate much faster.
For more details and an example, you can check the MSDN article on the Folder.GetTable Method for Outlook.
And for the specific filter that you are trying to apply, I would try:
"([ReceivedTime]>=12/1/17) AND ([ReceivedTime]<=12/30/17)"
You can create a collection of items restricted by date like this.
Option Explicit
Private Sub EmailInTimePeriod()
Dim oOlInb As Folder
Dim oOlItm As Object
Dim oOlResults As Object
Dim i As Long
Dim sFilterLower As String
Dim sFilterUpper As String
Dim sFilter As String
Dim dStart As Date
Dim dEnd As Date
Set oOlInb = Session.GetDefaultFolder(olFolderInbox)
' https://msdn.microsoft.com/en-us/library/office/ff869597.aspx
' 12/1/2017 to 12/30/2017
'dStart = "2017/12/01"
'dEnd = "2017/12/30"
' 1/12/2018 to 1/15/2018
dStart = "2018/01/12"
dEnd = "2018/01/16"
' Lower Bound of the range
sFilterLower = "[ReceivedTime]>'" & Format(dStart, "DDDDD HH:NN") & "'"
Debug.Print vbCr & "sFilterLower: " & sFilterLower
' *** temporary demo lines
' Restrict the items in the folder
Set oOlResults = oOlInb.Items.Restrict(sFilterLower)
Debug.Print oOlResults.count & " items."
If oOlResults.count > 0 Then
For i = 1 To oOlResults.count
Set oOlItm = oOlResults(i)
Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
Next i
End If
' *** temporary demo lines
' Upper Bound of the range
sFilterUpper = "[ReceivedTime]<'" & Format(dEnd, "DDDDD HH:NN") & "'"
Debug.Print vbCr & "sFilterUpper: " & sFilterUpper
' *** temporary demo lines
' Restrict the Lower Bound result
Set oOlResults = oOlResults.Restrict(sFilterUpper)
Debug.Print oOlResults.count & " items."
If oOlResults.count > 0 Then
For i = 1 To oOlResults.count
Set oOlItm = oOlResults(i)
Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
Next i
End If
' *** temporary demo lines
' combine the filters
sFilter = sFilterLower & " AND " & sFilterUpper
Debug.Print vbCr & "sFilter: " & sFilter
Set oOlResults = oOlInb.Items.Restrict(sFilter)
Debug.Print oOlResults.count & " items."
If oOlResults.count > 0 Then
For i = 1 To oOlResults.count
Set oOlItm = oOlResults(i)
Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
Next i
End If
ExitRoutine:
Set oOlInb = Nothing
Set oOlResults = Nothing
Set oOlItm = Nothing
Debug.Print "Done."
End Sub
Note the code is set up to be used in Outlook.
I am attempting to email to all email addresses in a table, with the subject line being the corresponding order number or numbers.
The Table has Five columns - "Line Number", "Order Number", "Suppler/Manf.Item Number", "Supplier Name" and "Email Address"
There can be duplicates, but the subject must contain each PO only once.
No CC, or BCC is required
The Body of the Email is to list the PO's with their associated line items.
Hello, We require an update as to the following:
EX
PO86001763
Line Item 2
Line Item 1
Please Send an update as to the status of these line items.
Providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates.
(These being able to be edited would be a boon)
The table is made from an import and format macro, it will always be in the same format, but will contain different data. The amount of data can increase or decrease depending on the week.
Here is my attempt.
Private Sub CommandButton2_Click()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1
Dim I As Integer
Dim X As Integer
Dim C As Object
Dim firstaddress As Variant
Dim Nrow As Boolean
Set tb = ActiveSheet.ListObjects("Table10")
For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
emAddress = tb.DataBodyRange.Cells(I, tb.ListColumns("Email Address").Index)
For X = LBound(myArray1) To UBound(myArray1)
On Error Resume Next
If emAddress = myArray1(X) Then GoTo goToNext
Next X
On Error GoTo 0
subjectLine = "Order(s) # "
ReDim Preserve myArray1(1 To nameCounter)
myArray1(nameCounter) = emAddress
nameCounter = nameCounter + 1
lineCounter = 1
With tb.ListColumns("Email Address").Range
Set C = .Find(emAddress, LookIn:=xlValues)
If Not C Is Nothing Then
firstaddress = C.Address
Beep
arrayCounter = arrayCounter + 1
Do
Nrow = C.Row - 1
If lineCounter = 1 Then
subjectLine = subjectLine & tb.DataBodyRange.Cells (Nrow, tb.ListColumns("Order Number").Index)
lineCounter = lineCounter + 1
bodyline = "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Line Number").Index)
Else:
subjectLine = subjectLine & ", " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index)
bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(Nrow, tb.ListColumns("Line Number").Index)
End If
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstaddress
End If
Run SendMailFunction(emAddress, subjectLine, bodyline)
' Debug.Print vbNewLine
' Debug.Print emAddress
' Debug.Print "Subject: " & subjectLine
' Debug.Print "Body:" & vbNewLine; bodyline
End With
goToNext:
Next I
Set C = Nothing
End Sub
Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
Dim I As Integer
NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table10")
For I = 1 To ActiveSheet.ListObjects("Table10").ListRows.Count
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = emAddress
.Subject = subjectLine
.Body = "Hello, We require an update as to the following:" & DNL & bodyline _
& DNL & _
"Please Send an update as to the status of these line items " & _
"providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Next I
End Function
The following code uses the email script as a function, which is called from the top macro. Please click on answer if this solves your problem
Sub findMethodINtable()
Dim subjectLine As String
Dim bodyline As String
Dim tb As ListObject
Dim lineCounter As Long
Dim myArray1, arrayCounter As Long, tempNumb As Long
Dim nameCounter As Long
Dim emAddress As String
ReDim myArray1(1 To 1)
arrayCounter = 0
nameCounter = 1
Set tb = ActiveSheet.ListObjects("Table14")
For i = 1 To ActiveSheet.ListObjects("Table14").ListRows.Count
emAddress = tb.DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
For x = LBound(myArray1) To UBound(myArray1)
On Error Resume Next
If emAddress = myArray1(x) Then GoTo goToNext
Next x
On Error GoTo 0
subjectLine = "Order(s) # "
ReDim Preserve myArray1(1 To nameCounter)
myArray1(nameCounter) = emAddress
nameCounter = nameCounter + 1
lineCounter = 1
With tb.ListColumns("Email Address").Range
Set c = .Find(emAddress, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Beep
arrayCounter = arrayCounter + 1
Do
nRow = c.Row - 1
If lineCounter = 1 Then
subjectLine = subjectLine & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index)
lineCounter = lineCounter + 1
bodyline = "Order " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Line Number").Index)
Else:
subjectLine = subjectLine & ", " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index)
bodyline = bodyline & vbNewLine & "Order " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Order Number").Index) & ", Line Number " & tb.DataBodyRange.Cells(nRow, tb.ListColumns("Line Number").Index)
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Run SendMailFunction(emAddress, subjectLine, bodyline)
' Debug.Print vbNewLine
' Debug.Print emAddress
' Debug.Print "Subject: " & subjectLine
' Debug.Print "Body:" & vbNewLine; bodyline
End With
goToNext:
Next i
Set c = Nothing
End Sub
Function SendMailFunction(emAddress As String, subjectLine As String, bodyline As String)
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table14")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = emAddress
.Subject = subjectLine
.Body = "Hello, We require an update as to the following:" & DNL & bodyline _
& DNL & _
"Please Send an update as to the status of these line items " & _
"providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End Function
This works for me, given table name is "Table14"
Sub wserlkug()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim tb As ListObject
Dim NL As String
Dim DNL As String
NL = vbNewLine
DNL = vbNewLine & vbNewLine
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set tb = ActiveSheet.ListObjects("Table14")
For i = 1 To ActiveSheet.ListObjects("Table14").ListRows.Count
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Email Address").Index)
.Subject = "Order # " & ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Order Number").Index)
.Body = "Hello, We require an update as to the following:" & DNL & "Line #: " & ActiveSheet.ListObjects("Table14").DataBodyRange.Cells(i, tb.ListColumns("Line Number").Index) _
& DNL & _
"Please Send an update as to the status of these line items " & _
"providing the following: Packing Slips, Tracking Numbers and Updated Ship Dates."
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Next i
End Sub
You can actually use the object variable "tb" instead of ActiveSheet.ListObjects("Table14").... I placed that there to show how to reference row and column in a table.
Hi Guys I'm kind of new to the macros and how to set it up.
I'm trying to run a automatic birthday macros that send an email out to people saying a happy birthday message.
but I'm struggling with when its Monday i want it to initiate a message for the weekend birthdays as well, but only on a Monday. My Code keeps saying "Run-time error '13': type mismatch". Here is my Code please help as I've been struggling a week with it
Sub send_bday_greet2()
Dim i As Long
Dim vbSunday As String, vbSaturday As String
For i = 2 To Sheets("Sheet1").Range("a1048576").End(xlUp).Row
If Day(Now()) = Day(CDate(Sheets("Sheet1").Range("c" & i).Value)) And Month(Now()) = Month(CDate(Sheets("Sheet1").Range("c" & i).Value)) Then
Call sending_bday_greetings_method2(Sheets("Sheet1").Range("a" & i).Value, Sheets("Sheet1").Range("b" & i).Value)
ElseIf Day(Now(vbMonday)) = Day(CDate(Sheets("Sheet1").Range("c" & i).Value)) And Month(Now(vbSaturday)) And Month(Now(vbSunday)) = Month(CDate(Sheets("Sheet1").Range("c" & i).Value)) Then
Call sending_bday_greetings_method2(Sheets("Sheet1").Range("a" & i).Value, Sheets("Sheet1").Range("b" & i).Value)
End If
Next
End Sub
Sub sending_bday_greetings_method2(nm As String, emid As String)
Dim olApp As Outlook.Application
Dim olMail As MailItem
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
s = "<p> <p align='left'><font size='3' face='arial' color='blue'><i> Dear " & nm & ", </p>" & vbNewLine
s = s & "<p> <p align='CENTER'><font size='3' face='arial' color='red'><i> We Wish you a very Happy Birthday! </p>" & vbNewLine
s = s & "<left><p align='CENTER'><img src=""http://simplyizzy.files.wordpress.com/2012/05/happy_birthday1.png"">" & vbNewLine
s = s & vbNewLine & "<left><p><p align='Left'><font size='3' face='arial' color='blue'><i>Regards<br>" & "Reutech Radar Systems</p>"
With olMail
.To = emid
.Subject = "Happy B'day!"
.HTMLBody = s
.Send
End With
Set olApp = Nothing
Set olMail = Nothing
End Sub
Your 1st issue is with Dim vbSunday As String, vbSaturday As String.
vbSaturday and vbSaturday are constants in VBA that are numbers, and you're trying to use them as String.
Furthermore, they are most probably protected so you won't be able to use their names as variable's name.
Your second issue is with Now(vbMonday) and others, you'll need to use a function like this to get the last day from the current date :
Public Function GetLastDay(ByVal DayAsVbConstant As Integer) As Date
GetLastDay = Now - (Weekday(Now, DayAsVbConstant) - 1)
End Function
Here is a revision of your code :
Sub send_bday_greet2()
Dim i As Long
Dim wS As Worksheet
Dim SendMessage As Boolean
Dim BirthDay As Date
'Set wS = ThisWorkbook.Sheets("Sheet1")
Set wS = ThisWorkbook.Sheets("Feuil1")
With wS
For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
SendMessage = False
BirthDay = CDate(.Range("C" & i).Value)
Select Case True
Case Day(Now()) = Day(BirthDay) And Month(Now()) = Month(BirthDay)
'Birthday this day
SendMessage = True
Case Weekday(Now) = vbMonday And ( _
Day(GetLastDay(vbSaturday)) = Day(BirthDay) And _
Month(GetLastDay(vbSaturday)) = Month(BirthDay))
'Birthday on Saturday
SendMessage = True
Case Weekday(Now) = vbMonday And ( _
Day(GetLastDay(vbSunday)) = Day(BirthDay) And _
Month(GetLastDay(vbSunday)) = Month(BirthDay))
'Birthday on Sunday
SendMessage = True
Case Else
End Select
If SendMessage Then Call sending_bday_greetings_method2(.Range("a" & i).Value, .Range("b" & i).Value)
Next i
End With 'wS
End Sub
And the part to send the mail :
Sub sending_bday_greetings_method2(ByVal nm As String, ByVal emid As String)
Dim olApp As Outlook.Application
Dim olMail As MailItem
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
s = "<p> <p align='left'><font size='3' face='arial' color='blue'><i> Dear " & nm & ", </p>" & vbNewLine
s = s & "<p> <p align='CENTER'><font size='3' face='arial' color='red'><i> We Wish you a very Happy Birthday! </p>" & vbNewLine
s = s & "<left><p align='CENTER'><img src=""http://simplyizzy.files.wordpress.com/2012/05/happy_birthday1.png"">" & vbNewLine
s = s & vbNewLine & "<left><p><p align='Left'><font size='3' face='arial' color='blue'><i>Regards<br>" & "Reutech Radar Systems</p>"
With olMail
.To = emid
.Subject = "Happy B'day!"
.HTMLBody = s
.Display
'.Send
End With
Set olApp = Nothing
Set olMail = Nothing
End Sub