this is my code. I have column C that has duplicate names and column B that has unique IDs I need to find which unique IDs match with what names and send an email to the names and paste the unique IDs in the email. I am getting an error on the first Me.Cells.
Sub sendEmails()
Dim dict_emails As Scripting.dictionary
Set dict_emails = New Scripting.dictionary
Dim objOutlook As Object
Dim objMailMessage As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim row As Range
Dim table As ListObject
Dim row_index As Long
Dim strEmail As String
Dim strExeptionID As String
ActiveWorkbook.Sheets("New 0-30").Select
Set table = ActiveSheet.ListObjects("New_030_Table")
For row_index = 1 To table.DataBodyRange.Rows.Count
strEmail = table.DataBodyRange(row_index, 3).Value
strExceptionID = table.DataBodyRange(row_index, 2).Value
If Not dict_emails.Exists(strEmail) Then
' first time we have seen this name
dict_emails.Add strEmail, strExceptionID
Else
dict_emails(strEmail) = dict_emails(strEmail) & vbCrLf & strExceptionID
End If
Next
Dim var_key As Variant
For Each var_key In dict_emails.Keys
Set objMailMessage = objOutlook.CreateItem(0) ' create new mail
With objMailMessage
.To = "" & var_key
.CC = ""
.BCC = ""
.Subject = "Exceptions Set to Expire in Less Than 30 Days"
.Body = "You have the following exceptions set to expire: " & vbCrLf & dict_emails(var_key)
.Save ' save as draft
End With
Next
End Sub
I was in same issue and I foung solution !!
but anyone will not believe in reference list "Microsoft Scripting Runtime" set priority to top 3rd. and it will start working and error will be gone.
Related
I've been failing miserably trying to write code for this, so I'd be happy if someone could help me create a macro in excel. I'm looking to send a bunch of users access credentials through outlook based off data I add to excel. Specifically, I have two worksheets:
1) Email Information (all static)
This contains:
Email Subject in cell C5
Email Body in Cell C6 (Essentially this says Hello, your user credentials are below)
Additional Email Body in Cell C7 (This portion would say something along the lines of "please let us know if you have any questions") Both cells C6 and C7 can of course be updated to include any language
2) User Information (number of users can vary)
This contains:
Column A - First Name
Column B - Last Name
Column C - Full Name (Not really needed)
Column D - Email Address
Column E - Password
Ideally, the macro would be able to look at the user information and create a new, separate email from outlook for every email address from column D with the following format:
Email To: email addresses in cell D2 until last email (User Information worksheet)
Email Subject: Cell C5 in Email information worksheet
"Hi" Firstname value from column A in User Information worksheet
Email Body Part 1 from cell C6 in Email Information worksheet
Username: which is the email address from column D (same as email recipient)
Password: from column E in User Information worksheet
Email Body PArt 2 from cell C7 in Email Information worksheet
Hope someone has the time to help me out.
Thanks in advance!!
EDIT
Thanks for the help, Barry. Here is my code as I'm trying to reference two different worksheets. Can you let me know what I'm doing wrong?
Sub GenerateEmail()
Dim sEmailBodyp1 As String
Dim sEmailBodyp2 As String
Dim sEmailSubject As String
Dim sEmailTo As String
Dim sFirstName As String
Dim sPassword As String
Dim OutApp As Object
Dim OutMail As Object
Dim EmailSheet As Worksheet
Dim UserSheet As Worksheet
Dim UsedRange As Range
Set EmailSheet = Sheets("Email Information")
Set UserSheet = Sheets("User Information")
Set sEmailSubject = EmailSheet.Cells("C5")
Set sEmailBodyp1 = EmailSheet.Cells("C6")
Set sEmailBodyp2 = EmailSheet.Cells("C7")
Set UsedRange = UserSheet.UsedRange
For Each Row In UsedRange.Rows
sFirstName = Row.Columns(1)
sEmailTo = Row.Columns(4)
sPassword = Row.Columns(5)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = sEmailTo
.Subject = sEmailSubject
.Body = "Hi " + sFirstName + "," + vbCrLf + vbCrLf + sEmailBodyp1 + vbCrLf + vbCrLf + "Username: " + sEmailTo + vbCrLf + "Password: " + sPassword + vbCrLf + vbCrLf + sEmailBodyp2
.Display
End With
Set OutMail = Nothing
Next
Set OutApp = Nothing
End Sub
Based on discussions this is my edit for this solution.
Excel Macro
Public Sub GenerateEmail()
Dim sEmailBodyp1 As String
Dim sEmailBodyp2 As String
Dim sEmailSubject As String
Dim sEmailTo As String
Dim sFirstName As String
Dim sPassword As String
Dim OutApp As Object
Dim OutMail As Object
Dim EmailSheet As Worksheet
Dim UserSheet As Worksheet
Dim UsedRange As Range
Set EmailSheet = Sheets("Email Information")
Set UserSheet = Sheets("User Information")
sEmailSubject = EmailSheet.Range("C5").Value
sEmailBodyp1 = EmailSheet.Range("C6").Value
sEmailBodyp2 = EmailSheet.Range("C7").Value
Set UsedRange = UserSheet.UsedRange
For Each Row In UsedRange.Rows.Offset(1, 0).Resize(UsedRange.Rows.Count - 1, UsedRange.Columns.Count)
sFirstName = Row.Columns(1)
sEmailTo = Row.Columns(4)
sPassword = Row.Columns(5)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = sEmailTo
.Subject = sEmailSubject
.Body = "Hi " + sFirstName + "," + vbCrLf + vbCrLf + sEmailBodyp1 + vbCrLf + vbCrLf + "Username: " + sEmailTo + vbCrLf + "Password: " + sPassword + vbCrLf + vbCrLf + sEmailBodyp2
.Display
End With
Set OutMail = Nothing
Next
Set OutApp = Nothing
End Sub
I created a macro that would run a report for a selected indivdual and send that person an email with that package. This report is meant for roughly 20 people, but it has been tedious to run the report for each person and then send it.
I was wondering if there was a way to type names in cells of the people I want to run the report to and have excel loop through each one and send that report to the selected individual and then loop to the next one.
Is this possible, and if so how would I go about creating this macro.
Thank you for your aid
Perhaps you can adjust the code below for your needs. It will send the contents of a textbox on the ActiveSheet to a list of emails in column A. To use it you have to set up your sending email account in Outlook.
Option Explicit
'how to send an email to a list of recipients based on data
'stored in a workbook. The recipient email addresses must
'be in column A, and the body text of the email must be in
'the first text box on the active sheet.
Sub Sample()
Dim olApp As Object, olMailItm As Object, i As Integer, j As Integer
Dim r As Range, s As String, numRows As Integer, numCols As Integer
Dim Dest As Variant, emailAddr As String, txtBox As Shape
'Create the Outlook application and the empty email.
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
Set txtBox = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
200, 100, 400, 100)
'.TextFrame.TextRange.Text = "Test Box"
'Using the email, add multiple recipients, using a list of addresses in column A.
Set r = Range("B1")
s = "": numCols = 4: numRows = 4
For j = 1 To numCols
For i = 1 To numRows
If i > 1 Then s = s & vbTab
s = s & r.Offset(j, i)
Next i
s = s & vbCr
Next j
txtBox.TextFrame2.TextRange.Characters.Text = s
With olMailItm
emailAddr = ""
For i = 1 To WorksheetFunction.CountA(Columns(1))
If emailAddr = "" Then
emailAddr = Cells(i, 1).Value
Else
emailAddr = emailAddr & ";" & Cells(i, 1).Value
End If
Next i
'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
.BCC = emailAddr
.Subject = "FYI"
'.body = txtBox.Text
.body = ActiveSheet.TextBoxes(1).Text
.Send
End With
'Clean up the Outlook application.
Set olMailItm = Nothing
Set olApp = Nothing
End Sub
I'm trying to create a macro in MS-Word VBA to take the contents of a MS-Word table (with a bookmarked name), iterate through the rows of the table and create tasks in MS-Outlook (1 row=1 task).
I have Googled and think I will need to try and mix together the following two scripts I have found:
Script 1 - (For making calendar entries - not wanted, but iteration through rows - wanted)
Sub AddAppntmnt()
'Adds a list of events contained in a three column Word table
'with a header row, to Outlook Calendar
Dim olApp As Object
Dim olItem As Object
Dim oTable As Table
Dim i As Long
Dim bStarted As Boolean
Dim strStartDate As Range
Dim strEndDate As Range
Dim strSubject As Range
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oTable = ActiveDocument.Tables(1)
'Ignore the first (header) row of the table
For i = 2 To oTable.Rows.Count
Set strStartDate = oTable.Cell(i, 1).Range
strStartDate.End = strStartDate.End - 1
Set strEndDate = oTable.Cell(i, 2).Range
strEndDate.End = strEndDate.End - 1
Set strSubject = oTable.Cell(i, 3).Range
strSubject.End = strSubject.End - 1
Set olItem = olApp.CreateItem(1)
olItem.Start = strStartDate
olItem.End = strEndDate
olItem.ReminderSet = False
olItem.AllDayEvent = True
olItem.Subject = strSubject
olItem.Categories = "Events"
olItem.BusyStatus = 0
olItem.Save
Next i
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
Set oTable = Nothing
End Sub
Script 2 - has the actual task creation bit I think I need although this one is about setting task to remind user to do something in 2 weeks or something:
Sub AddOutlookTask()
Dim olApp As Object
Dim olItem As Object
Dim bStarted As Boolean
Dim fName As String
Dim flName As String
On Error Resume Next
If ActiveDocument.Saved = False Then
ActiveDocument.Save
If Err.Number = 4198 Then
MsgBox "Process ending - document not saved!"
GoTo UserCancelled:
End If
End If
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set olItem = olApp.CreateItem(3) 'Task Item
fName = ActiveDocument.name
flName = ActiveDocument.FullName
olItem.Subject = "Follow up " & fName
olItem.Body = "If no reply to" & vbCr & _
flName & vbCr & "further action required"
olItem.StartDate = Date + 10 '10 days from today
olItem.DueDate = Date + 14 '14 days from today
olItem.Importance = 2 'High
olItem.Categories = InputBox("Category?", "Categories")
olItem.Save
UserCancelled:
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
End Sub
How do I reference a particular table in MS-Word in code? I have bookmarked it so it has a "name" if that helps!
With Davids help (above) I have got the following solution to my problem. I post here for others if they come across a similar issue:
Sub CreateTasks()
'
' CreateTasks Macro
'
'
'
'Exports the contents of the ACtoins table to MS-Outlook Tasks
' Set Variables
Dim olApp As Object
Dim olItem As Object
Dim oTable As Table
Dim i As Long
Dim strSubject As Range
Dim strDueDate As Range
Dim strBody As Range
Dim strSummary As String
Dim bStarted As Boolean
'Dim strPupil As WdBookmark
Dim strPerson As Range
'Link to Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
'Set table variable to the bookmarked table
Set oTable = ActiveDocument.Bookmarks("Actions").Range.Tables(1)
'Ignore the first (header) row of the table
For i = 3 To oTable.Rows.Count
Set strSubject = oTable.Cell(i, 3).Range
strSubject.End = strSubject.End - 1
Set strBody = oTable.Cell(i, 4).Range
strBody.End = strBody.End - 1
Set strDueDate = oTable.Cell(i, 5).Range
strDueDate.End = strDueDate.End - 1
'next line not working below
'Set strPupil = WdBookmark.Name
'Create the task
Set olItem = olApp.CreateItem(3) 'Task Item
strSummary = Left(strSubject, 30)
olItem.Subject = "CYPP Action for" & " " & strBody & "-" & strSummary & "..."
olItem.Body = strBody & vbNewLine & olItem.Body & vbNewLine & strSubject
olItem.DueDate = strDueDate & olItem.DueDate
olItem.Categories = "CYPP"
olItem.Save
Next i
If bStarted Then olApp.Quit
Set olApp = Nothing
Set olItem = Nothing
Set oTable = Nothing
End Sub
I will be adding to this to deal with empty rows but I am pleased with the functionality so far. The DateDue is not working yet but I think that is a formatting issue.
Thanks again David,
Richard.
I can send a single Outlook message using Excel VBA. However, I want to loop through my rows and send an email for each row that meets a certain condition.
Unfortunately, when I put the email code in a for loop only one email gets sent or none at all (depending on how I structure the code).
Is there something about calling Outlook multiple times that I should know?
Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
For Each cell In contactRange
If Range(Cells(cell.Row, cell.Column).Address).Value = "Yes" Then
nextAddy = Range(Cells(cell.Row, cell.Column).Address).Offset(0, 5).Value
toAddy = nextAddy & ", " & toAddy
End If
Next cell
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2)
End If
For i = 0 To 1 'short loop for testing purposes
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next i
End Sub
Take the CreateObject line out of the loop:
Set OutApp = CreateObject("Outlook.Application")
For i = 0 To 1 'short loop for testing purposes
Set OutMail = OutApp.CreateItem(0)
...
I've tried to clean up your logic stream but there are many unanswered questions due to the lack of sample data, explicit error messages and output.
Private Sub CommandButton1_Click()
Dim outApp As Object
Dim outMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
With Worksheets(contactRange.Parent.Name) '<~~ surely you know what worksheet you are on..!?!
For Each cell In contactRange
If cell.Value = "Yes" Then 'no need to define a range by the range's address
nextAddy = cell.Offset(0, 5).Value 'again, no need to define a range by the range's address
toAddy = nextAddy & ";" & toAddy 'use a semi-colon to concatenate email addresses
End If
Next cell
End With
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2) 'I have no idea why you need to shorten the toAddy by 2
'only send mail where one or more addresses exist
For i = 0 To 1 'short loop for testing purposes
Set outMail = outApp.CreateItem(0)
With outMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set outMail = Nothing
Next i
End If
Set outApp = Nothing
End Sub
OK, so I re-wrote the code based on the feedback. I used a loop to send emails one at a time instead of concatenating the addresses together as I wanted to personalize each email. I also needed to create a form to handle the input as inputbox only accepts 256 characters.
A form was pretty much required as I needed to capture the subject line, message body, salutation, path the to the attachment etc.:
Private Sub CommandButton1_Click()
Dim subject As String, msg As String, path As String
subject = TextBox1.Value
msg = TextBox2.Value & vbCrLf & vbCrLf & "Sincerely," & vbCrLf & TextBox4.Value & vbCrLf & TextBox5
path = TextBox3.Value
UserForm1.Hide
Module1.sendEmail subject, msg, path
End Sub
I placed the email code in Module1. Note, be sure to set the .sentOnBehalfOfName attribute or Outlook will simply pick an account which may not be the one you want if you have multiple accounts registered:
Public Sub sendEmail(subject As String, msg As String, path As String)
Dim outApp As Object
Dim outMail As Object
Dim contactRange As Range, cell As Range
Dim toAddy As String, emailMsg As String
Dim count As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Range("ContactYesNo")
With Worksheets("IT consulting")
For Each cell In contactRange
If cell.Value = "Yes" Then
count = count + 1
toAddy = cell.Offset(0, 6).Value
emailMsg = "Dear " & cell.Offset(0, 2).Value & "," & vbCrLf & vbCrLf & msg
Set outMail = outApp.CreateItem(0)
With outMail
.SentOnBehalfOfName = "me#someemail.com"
.To = toAddy
.CC = ""
.BCC = ""
.subject = subject
.Body = emailMsg
.Attachments.Add path
'.Display
.Send
End With
'log the action
cell.Offset(0, 1).Value = Now & vbCrLf & cell.Offset(0, 1).Value
End If
Set outMail = Nothing
Next cell
End With
Set outApp = Nothing
MsgBox "total emails sent: " & count
End Sub
How do I make it so the email address for the recipient name is taken from a different column.
I have the names written out in a column and I want to check the date in the same row for each person and if its 1 month out then send an email to that person. I can only reference one specific cell but I need it for each row as it iterates down the P column.
Sub Workbook_Open()
Dim Cell As Range
Dim objDate As Date
For Each Cell In Range("P3:P4").Cells
If Cell.Value <= Date + 30 Then
'MsgBox "Going to expire in 1 month"
Dim appOutlook As Outlook.Application
Dim mitOutlookMsg As Outlook.MailItem
Dim recOutlookRecip As Outlook.Recipient
' Step 1: Initialize an Outlook session.
Set appOutlook = CreateObject("Outlook.Application")
' Step 2: Create a new message.
Set mitOutlookMsg = appOutlook.CreateItem(olMailItem)
With mitOutlookMsg
' Step3: Add the To recipient(s) to message.
Set recOutlookRecip = .Recipients.Add(Cells(3, 2))
recOutlookRecip.Type = olTo
'Set valid properties like Subject, Body, and Importance of the message.
.Subject = "Test123"
'.Body = "Test"
.BodyFormat = olFormatHTML
.HTMLBody = " TEST EMAIL "
.Importance = olImportanceHigh 'High importance
' Resolve every Recipient's name
For Each recOutlookRecip In .Recipients
recOutlookRecip.Resolve
If Not recOutlookRecip.Resolve Then
mitOutlookMsg.Display
End If
Next
.Send
End With
Set mitOutlookMsg = Nothing
Set appOutlook = Nothing
Else
End If
Next Cell
End Sub
I think what you're looking for is:
Range.Offset(row, col)
For example:
For Each Cell In Range("P3:P4").Cells
'cell.Value refers to P3:P4
myDate = cell.Value
'cell.Offset(0, 1).Value refers to the column one to the right of cell
myName = cell.Offset(0, 1).Value
Next cell