I'm having trouble with my variable y. I'm getting the next without For error, when trying to run the macro.
Dim y As Long
Dim Lastrow As Long
Lastrow = Sht1.Cells(Sht1.Rows.Count, "B").End(xlUp).Row
For Each cell In sht3.Columns("B").Select
If Not IsEmpty(ActiveCell.Value) Then
With Outmail
.to = ActiveCell.Offset(ColumnOffset:=1)
.Subject = "OE input sheet " & ActiveCell.Value & ": Service Delivered = NO"
.body = "Hello " & ActiveCell.Offset(ColumnOffset:=-1).Value & vbNewLine & vbNewLine & "Test" & vbNewLine & vbNewLine
For y = 2 To Lastrow
Sht1.Range("B" & y).Select
If Application.WorksheetFunction.Match(ActiveCell.Value, sht3.Range("B:B"), 0) Then
.body = ActiveCell.Offset(ColumnOffset:=-1).Value
Next y
.Send
End With
On Error GoTo 0
Set Outmail = Nothing
End If
Next cell
Thanks in advance
Dim y As Long
Dim Lastrow As Long
Lastrow = Sht1.Cells(Sht1.Rows.Count, "B").End(xlUp).Row
For Each cell In sht3.Columns("B").Select
If Not IsEmpty(ActiveCell.Value) Then
With Outmail
.to = ActiveCell.Offset(ColumnOffset:=1)
.Subject = "OE input sheet " & ActiveCell.Value & ": Service Delivered = NO"
.body = "Hello " & ActiveCell.Offset(ColumnOffset:=-1).Value & vbNewLine & vbNewLine & "Test" & vbNewLine & vbNewLine
For y = 2 To Lastrow
Sht1.Range("B" & y).Select
If Application.WorksheetFunction.Match(ActiveCell.Value, sht3.Range("B:B"), 0) Then
.body = ActiveCell.Offset(ColumnOffset:=-1).Value
End If
Next y
.Send
End With
On Error GoTo 0
Set Outmail = Nothing
Next cell
Related
I can not get Excel to see row three as a separate line of data. My code is adding all the attachments from row three to the email with information generated from row two.
How can I loop through rows 2 to the last row with data?
I am trying to send an email using the information filled in each cell of each row. I am using this current code since it is the only way I can get a signature line to work.
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim I As Integer
Dim last_row As Integer
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
For I = 2 To last_row
.display
.SentOnBehalfOfName = sh.Range("A" & I).Value
.To = sh.Range("B" & I).Value
.CC = sh.Range("C" & I).Value
.Subject = sh.Range("D" & I).Value
.HTMLBody = strbody & "<br>" & .HTMLBody
If sh.Range("F" & I).Value <> "" Then
.attachments.Add sh.Range("F" & I).Value
End If
If sh.Range("G" & I).Value <> "" Then
.attachments.Add sh.Range("G" & I).Value
End If
If sh.Range("H" & I).Value <> "" Then
.attachments.Add sh.Range("H" & I).Value
End If
I don't think the last part of the code is worth much it is just strbody =. I originally wanted the body to be a variable. That presented the problem of not being able to use a signature line.
I think what you had in mind was perhaps as shown below. The code creates an email text, including some snippets from the worksheet, which can then be assigned to the HTMLbody.
Dim Txt As String
Dim Line As String
Dim C As Long
Txt = "Dear Sir," & vbNewLine & vbNewLine & _
"Please take note of the following." & vbNewLine
Line = ""
For C = 6 To 8
With sh.Cells(i, C)
If Len(.Value) Then
If Len(Line) Then Line = Line & ", "
Line = Line & .Value
End If
End With
Next C
If Len(Line) Then Txt = Txt & Line & vbNewLine
Txt = Txt & "Please get back to me ASAP." & vbNewLine & vbNewLine
Txt = Txt & " Regards" & vbNewLine & "John Doe"
Hello Everyone i was wondering if anyone can help me resolve my problem., i have got code which i found from the net which is working absolutely perfect however only problem is that when there is more than one due date in the column it will send email each time instead of sending all due date and names in One email at same time. Names it is on column A, Expiry Date it is in column E, and email stamp as sent in Column F, below its the code.
Private Sub Workbook_Open()
Dim Email As String, Subj As String, Msg As String, wBox As String
Dim RowNo As Long, i As Long, ky As Variant, cad As Variant
Dim wsEmail As Worksheet, OutApp As Object, OutMail As Object, dic As Object
Set wsEmail = ThisWorkbook.Sheets("Tracker")
Set dic = CreateObject("scripting.dictionary")
With wsEmail
For RowNo = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(RowNo, "E") <> "" Then
If .Cells(RowNo, "F") = "" And .Cells(RowNo, "E") <> "" And .Cells(RowNo, "E") <= Date + 60 Then
If dic.exists(.Cells(RowNo, "F").Value) Then
dic(.Cells(RowNo, "A").Value) = dic(.Cells(RowNo, "A").Value) & RowNo & "|"
Else
dic(.Cells(RowNo, "A").Value) = RowNo & "|"
End If
End If
End If
Next
For Each ky In dic.keys
cad = Left(dic(ky), Len(dic(ky)) - 1)
cad = Split(cad, "|")
wBox = ""
dBox = ""
For i = 0 To UBound(cad)
wBox = wBox & " " & wsEmail.Cells(cad(i), "A")
dBox = wsEmail.Cells(cad(i), "E")
.Cells(cad(i), "F") = "Sent"
.Cells(cad(i), "G") = Environ("username")
.Cells(cad(i), "H") = "E-mail sent on: " & Now()
Next
On Error Resume Next
Set OutApp = GetObject("Outlook.Application")
On Error GoTo 0
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
Do: Loop Until Not OutApp Is Nothing
Set OutMail = OutApp.CreateItem(0)
With OutMail
Subj = wBox & Space(1) & "from will expire soon"
Msg = "Hi" & vbCrLf & vbCrLf _
& "This is an automated e-mail to let you know that" & wBox & Space(1) & " will expire as follow;" & vbCrLf & vbCrLf _
& "Expiry date:" & dBox & vbCrLf & vbCrLf & "Many Thanks " & vbCrLf _
& vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
.To = "Sent to"
.CC = ""
.BCC = ""
.Subject = Subj
.ReadReceiptRequested = False
.Body = Msg
.Display
End With
mystring = ("Email has been sent for below staff;") & _
vbCrLf & vbCrLf & ky
MsgBox mystring
Set OutApp = Nothing
Set OutMail = Nothing
Next
End With
End Sub
is there any way to do this?
This should get you started.
Read the code's comments and adjust it to fit your needs.
Private Sub SendEmails()
Dim trackerSheet As Worksheet
Set trackerSheet = ThisWorkbook.Worksheets("CTCTracker")
Dim lastRow As Long
lastRow = trackerSheet.Cells(trackerSheet.Rows.Count, "A").End(xlUp).Row
Dim trackerRange As Range
Set trackerRange = trackerSheet.Range("A5:A" & lastRow)
' Declare boolean to check if there are any expiring names
Dim anyExpiring As Boolean
Dim nameCell As Range
For Each nameCell In trackerRange
' Check: 1) There is a expiring date
' 2) Email not sent yet
' 3) Expiring date less than today + 60 días
If nameCell.Offset(0, 4).Value <> "" And _
nameCell.Offset(0, 5).Value = "" And _
nameCell.Offset(0, 4).Value <= Date + 60 Then
' Store names and expiring dates into array
Dim infoArray() As Variant
Dim counter As Long
ReDim Preserve infoArray(counter)
infoArray(counter) = Array(nameCell.Value, nameCell.Offset(0, 4).Value)
counter = counter + 1
' Stamp action log
nameCell.Offset(0, 5).Value = "Sent"
nameCell.Offset(0, 6).Value = Environ$("username")
nameCell.Offset(0, 7).Value = "E-mail sent on: " & Now()
' To be able to check later
anyExpiring = True
End If
Next nameCell
' Exit if there are not expiring contacts
If Not anyExpiring Then
MsgBox "There are not expiring contacts"
Exit Sub
End If
' Prepare message
Dim namesList As String
For counter = 0 To UBound(infoArray)
namesList = namesList & infoArray(counter)(0) & vbTab & vbTab & " | " & vbTab & vbTab & infoArray(counter)(1) & vbNewLine
Next counter
Dim emailBodyTemplate As String
emailBodyTemplate = "This is an automated e-mail to let you know that the following CTC will expire as follow:" & vbCrLf & vbCrLf & _
"Name" & vbTab & vbTab & vbTab & " | " & vbTab & vbTab & vbTab & " CTC Expiry date" & vbCrLf & _
"<namesList>" & vbCrLf & vbCrLf & _
"Many Thanks " & vbCrLf & _
vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
Dim emailBody As String
emailBody = Replace(emailBodyTemplate, "<namesList>", namesList)
' Start outlook (late bound)
Dim outApp As Object
On Error Resume Next
Set outApp = GetObject("Outlook.Applicatin")
On Error GoTo 0
' If outlook is not running, start an instance
If outApp Is Nothing Then Set outApp = CreateObject("Outlook.Application")
Do: Loop Until Not outApp Is Nothing
' Compose email
Dim outMail As Object
Set outMail = outApp.CreateItem(0)
With outMail
.To = "Sent to"
.CC = ""
.BCC = ""
.Subject = "CTC will expire soon"
.ReadReceiptRequested = False
.Body = emailBody
.Display
End With
' Display message to user
Dim staffMessage As String
staffMessage = ("Email has been sent for below staff")
MsgBox staffMessage
' Clean up
Set outApp = Nothing
Set outMail = Nothing
End Sub
Let me know if it works
My goal: An Excel spreadsheet with VBA code, where
- User ID in Column A is used for the sending address.
- user's first name in Column B is used in the greeting line of the email body.
What I have: I created multiple emails with an email body for each User ID in Column A.
What I cannot figure out: How to use the name from Column B in the email body.
For every email:
Here is the code thus far, asterisks have been used to replace email text.
Sub SendEmail()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
Dim strbody As String
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
strbody = "Hello " & vbNewLine & _
"***********************" & vbNewLine & vbNewLine & _
"***********************" & vbNewLine & _
"***********************" & vbNewLine & vbNewLine & _
"***********************" & vbNewLine & _
"***********************" & vbNewLine
For i = 2 To lr
With Mail_Object.CreateItem(o)
.Subject = Range("C2").Value
.To = Range("A" & i).Value
.Body = strbody
.SentOnBehalfOfName = "*****"
'.Send
.display 'disable display and enable send to send automatically
End With
Next i
'MsgBox "E-mail successfully sent", 64
'Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
Just add the value from cell(2,i) to .body in the loop like below
`Sub SendEmail()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
Dim strbody As String, Strbody1 as String
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
strbody = "Hello "
strbody1 = vbNewLine & _
"***********************" & vbNewLine & vbNewLine & _
"***********************" & vbNewLine & _
"***********************" & vbNewLine & vbNewLine & _
"***********************" & vbNewLine & _
"***********************" & vbNewLine
For i = 2 To lr
With Mail_Object.CreateItem(o)
.Subject = Range("C2").Value
.To = Range("A" & i).Value
.Body = strbody & Range("B" & i).Value & strbody2
.SentOnBehalfOfName = "*****"
'.Send
.display 'disable display and enable send to send automatically
End With
Next i
'MsgBox "E-mail successfully sent", 64
'Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub`
Will give my comment as an answer:
First, do the Excel activities at once, storing what's needed in variables so you're not changing focus back and fourth between Excel/Outlook:
Public toString as String
Private Sub excelActivities()
with thisworkbook.sheets("NAME")
dim lr as long
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
dim i as long
for i = 2 to lr
toString = toString & ";" & .Cells(i,1).Value
next i
end with
End Sub
Then you can use your Excel values, stored as variables, when performing your Outlook activities... could be two separate subroutines called in series:
Sub generateEmail()
excelActivities
outlookActivities
End Sub
Your outlookActivities would include creating the email, adding the .To = toString, etc.
I am using below code to send email from excel when user press the button. it works fine. i actually want to fine tune this because right now what is happening is when in Column C there is a duplicate email and in column N it is all yes separate emails are generated. what i want to do is if there is a duplicate email in column C one email should be generated with subject and body from the duplicate rows
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
'On Error Resume Next
LastRow = Range("C" & Rows.Count).End(xlUp).Row
For Each Cell In Range("C8:C" & LastRow)
If WorksheetFunction.CountIf(Range("C8:C" & Cell.Row), Cell) = 1 Then
If Cells(Cell.Row, 14) = "Yes" Then
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Dear " & Cells(Cell.Row, 2) & vbNewLine & vbNewLine & _
Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & vbNewLine & _
"were issue to you for project " & Cells(Cell.Row, 8) & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
"This is a system generated email and doesn't require signature"
On Error Resume Next
With xOutMail
.To = Cells(Cell.Row, 3)
.CC = Cells(Cell.Row, 5)
.BCC = ""
.Subject = Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & " Issued to " & Cells(Cell.Row, 4)
.Body = xMailBody
'.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End If
End If
Next Cell
You can try:
Option Explicit
Public Sub Get_Unique_Count_Paste_Array()
Dim Ob As Object
Dim rng As Range
Dim LR As Long
Dim str As String
With Worksheets("Sheet1")
LR = .Range("C" & Rows.Count).End(xlUp).Row
Set Ob = CreateObject("scripting.dictionary")
For Each rng In .Range("C8:C" & LR)
str = Trim(rng.Value)
If Len(str) > 0 Then
Ob(str) = Ob(str) + 1
If Ob(str) = 1 Then '<= Check how many times email address appears in the array & if it s appears only one time then..
MsgBox str '<= Insert your code here
End If
End If
Next rng
End With
End Sub
I have to rewrite code which works on Win but doesn't on Mac.
When I run the code I got error:
Run-time error '429': ActiveX component can't create object
at line: Set iMsg = CreateObject("CDO.Message").
I already Google thru Internet.
Dim msgbox1
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim xRange As Range
Dim xCell As Long
Dim xCount As Long
Dim i As Long
' First run the checks that all needed info is there
' before we display the form
If frmEmail.fldSubject.TextLength < 5 Then
MsgBox "Please fill in a subject for the email", vbExclamation
Exit Sub
End If
If frmEmail.fldEmailBox.TextLength < 5 Then
MsgBox "Please put some information in the email body", vbExclamation
Exit Sub
End If
msgbox1 = MsgBox("Are you sure you want to email all selected users in this Directorate: " & _
vbCrLf & vbCrLf & Worksheets("Contact Info").Cells(12, 4), vbOKCancel + vbExclamation, "Attention! Attention!! Attention!!!")
If msgbox1 = vbOK Then
msgbox1 = MsgBox("Are you sure you want to email all users using the following SMTP server: " & _
vbCrLf & vbCrLf & Worksheets("ADMIN").Cells(25, 3), vbOKCancel + vbExclamation, "Attention! Attention!! Attention!!!")
If msgbox1 = vbOK Then
Rem msgbox1 = MsgBox("Place holder for email function")
'Here we go with emailing
Sheets("Users Details Form").Activate
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Trim(Worksheets("ADMIN").Range("c24").Value)
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
Set xRange = Worksheets("Users Details Form").Range("A1:A65536")
xCount = Application.CountIf(xRange, "x")
For i = 1 To xCount
strbody = frmEmail.fldEmailBox.Text
xCell = xRange.Find("x").Row
strbody = Replace(strbody, "%%user%%", Range("B" & xCell) & " " & Range("C" & xCell))
strbody = Replace(strbody, "%%username%%", Range("F" & xCell))
strbody = Replace(strbody, "%%password%%", Range("G" & xCell))
strbody = Replace(strbody, "%%role%%", Range("H" & xCell))
On Error Resume Next
With iMsg
Set .Configuration = iConf
.To = Range("D" & xCell).Value
.CC = ""
.BCC = ""
.From = "" & Worksheets("ADMIN").Range("C22").Value & "<" & Worksheets("ADMIN").Range("C23").Value & ">"
.Subject = frmEmail.fldSubject.Text
.TextBody = strbody
.Send
End With
If Err.Number <> 0 Then
Range("A" & xCell).Value = "F"
Range("A" & xCell).DisplayFormat.Interior.ColorIndex = iRed
Else
If frmEmail.btnNewUserEmail Then
Range("A" & xCell).Value = "N"
Range("A" & xCell).DisplayFormat.Interior.ColorIndex = Range("A1").DisplayFormat.Interior.ColorIndex
End If
If frmEmail.btnExistingUserEmail Then
Range("A" & xCell).Value = "E"
Range("A" & xCell).DisplayFormat.Interior.ColorIndex = Range("A1").DisplayFormat.Interior.ColorIndex
End If
If frmEmail.btnCustom Then
Range("A" & xCell).Value = "C"
Range("A" & xCell).DisplayFormat.Interior.ColorIndex = Range("A1").DisplayFormat.Interior.ColorIndex
End If
End If
On Error GoTo 0
Next
End If
End If
End
Check your references by going to Tools->References in the VBA editor, make sure none are marked as "missing".
If no references are missing, then typically this is due to a corrupt workbook.
The solution is to create a new workbook and copy your VBA code into it.
This means you will need to recreate any worksheets, formatting etc that might be in your corrupted workbook.