I need to change the colour of: 'Cells(cell.Row, "A").Value' Cells(cell.Row, "E").Value to blue.
Can you help?
Sub Test1()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Test As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "TITLE" & " - " & Format(Now, "dd_mmmm_yyyy")
.Body = Test & "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Text1" & _
vbNewLine & vbNewLine & _
"Text2'" & Cells(cell.Row, "E").Value & "TEXT" & _
vbNewLine & vbNewLine & _
"TEXT3" & _
vbNewLine & vbNewLine & _
"TEXT4" & _
vbNewLine & vbNewLine & _
"TEXT5" & _
vbNewLine & vbNewLine & "Many thanks," & vbNewLine & vbNewLine & "DCX PMO Team"
'Adding an attachment
.Attachments.Add ("D:\Users\ABOHANNO\Desktop\Digital Transformation\tagging\DCX Sales Process.pptx")
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Try this:
cell.Resize(1,5).Font.Color = vbBlue
Related
Im using below vba query to generate emails with attachment. However, i do not want the query to generate the details in attachments. Instead, i want the data to be paste in body of the email. Im not sure how to amend it. Please help
Sub Buyer_HU()
Dim c As Range, sh As Worksheet, Ky As Variant, dam As Variant, dict As Object
Dim correo As String, lr As Long, wFile As String
Dim tempData As String '<== Changes here
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = Sheets("Template")
If sh.AutoFilterMode Then sh.AutoFilterMode = False
lr = sh.Range("A" & Rows.Count).End(xlUp).Row
sh.Range("BA:BA").ClearContents
For Each c In sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
sh.Range("BA" & c.Row) = c & sh.Range("M" & c.Row) & sh.Range("M" & c.Row)
Next
Set dict = CreateObject("scripting.dictionary")
For Each c In sh.Range("BA2", sh.Range("BA" & Rows.Count).End(xlUp))
dict.Item(c.Value) = sh.Range("M" & c.Row)
Next
For Each Ky In dict.Keys
correo = dict(Ky)
sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky
sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky, xlOr, " ", True
'ActiveSheet.Range("$A$1:$BA$2000").AutoFilter 53
Workbooks.Add
sh.AutoFilter.Range.EntireRow.Copy Range("A1")
Dim wcc
wcc = Range("AY1")
Range("BA:BA").ClearContents
Range("BA:BA").ClearContents
Range("AY:AY").ClearContents
Range("M:M").ClearContents
Cells.Select
Selection.Columns.AutoFit
Range("A2").Select
tempData = ActiveSheet.Range("A2").Value '<== Changes here
wFile = ThisWorkbook.Path & "\Back orders report " & Format(Now(), "dd.mm.yyyy") & "_" & tempData & ".xlsx" '<== Changes here
ActiveWorkbook.SaveAs wFile
ActiveWorkbook.Close False
Set dam = CreateObject("Outlook.Application").CreateItem(0)
With dam
.SentOnBehalfOfName = wcc
'.Bodyformat = olFormatHTML
.To = correo
.cc = ""
.Subject = "Back orders report " & Format(Now(), "dd.mm.yyyy") & "_" & tempData '<== Changes here
.HTMLBody = "Good Morning," & "<br>" & "<br>" & "Please see attached for today's reports." & "<br>" & "<br>" & "Please use the below coding:" & "<br>" & "<br>" & "07/12/2030 - means call off order" & "<br>" & "06/12/2030 - means shipped and orders can be invoiced off" & "<br>" & "05/12/2030 - means order not received - please resend" & "<br>" & "04/12/2030 - means order cancelled - please cancel off at your end if not already done" & "<br>" & "03/12/2030 - means delivery date not known" & "<br>" & "02/12/2030 - means held, more info required" & "<br>" & "01/12/2030 - means held, price problem" & "<br>" & "<br>" & "All other dates should be ETA?dates (If promise date is unchanged please leave blank)" & "<br>" & "<br>" & "PLEASE REPLY IN FORMAT SENT" & "<br>" & "<br>" & "Backorder Report - Please Return by 12pm." & "<br>" & "<br>" & "Thanks and Regards," & "<br>" & "Currys B2B Planning Team"
.Attachments.Add wFile
.Display 'use .Send to send
End With
Next Ky
'sh.ShowAllData
'Selection.AutoFilter
Columns("BA:BA").Select
Selection.Delete Shift:=xlToLeft
MsgBox "Emails generated"
Range("A2").Select
End Sub
I wonder whether someone could help me please.
I'm trying to write a script which send multiple emails to addressees on a spreadsheet, with various other pieces of information.
I've started to use a solution from Ron de Bruin (below).
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Src As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set Src = ThisWorkbook.Sheets("List")
On Error GoTo cleanup
Src.Select
For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Splunk Access"
.Body = "Hi " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"I have created an account: Production." & _
vbNewLine & vbNewLine & _
"Your username and password for this environment is:" & _
vbNewLine & vbNewLine & _
"Username: " & Cells(cell.Row, "B").Value & _
vbNewLine & _
"Password: " & Cells(cell.Row, "E").Value & _
vbNewLine & vbNewLine & _
"Please log in at your earliest convenience and change your password to a more secure one. " & _
vbNewLine & vbNewLine & _
"You can do this by clicking on your name on the top menu and select ‘Edit Account’." & _
vbNewLine & vbNewLine & _
"You can use this link to get to the log in page for this environment: " & _
vbNewLine & vbNewLine & _
"PROD: right/en-US/account/logout " & _
vbNewLine & vbNewLine & _
"Many thanks and kind regards"
.send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
This script works, but I then receive the 'Outlook' security ,message, which with over 100 recipients, isn't practical to keep pressing "Ok" to send the email.
So following more research I changed:
.send
to
.Display
Application.Wait (Now + TimeValue("0:00:01"))
Application.SendKeys "%"
But the problem I have is that the email is created, but isn't sent. Again not practical to keep pressing "Send" for over 100 users.
I then tried a CDO solution, but I ran into problems with the SMTP address because I'm using my works Microsoft Exchange which I'm not an administrator for, and so don't have any of the SMTP details.
I just wondered whether someone may be able to look a this please, and offer some guidance on how I can create the macro to run automatically.
Many thanks and kind regards
Chris
All,
I managed to get this working with the following:
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Src As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set Src = ThisWorkbook.Sheets("List")
On Error GoTo cleanup
Src.Select
For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Access"
.Body = "Hi " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"I have created an account for you" & _
vbNewLine & vbNewLine & _
"Your username and password for this environment is:" & _
vbNewLine & vbNewLine & _
"Username: " & Cells(cell.Row, "B").Value & _
vbNewLine & _
"Password: " & Cells(cell.Row, "E").Value & _
vbNewLine & vbNewLine & _
"Please log in at your earliest convenience and change your password to a more secure one. " & _
vbNewLine & vbNewLine & _
"You can do this by clicking on your name on the top menu and select 'Edit Account'." & _
vbNewLine & vbNewLine & _
"You can use this link to get to the log in page for this environment: " & _
vbNewLine & vbNewLine & _
"PROD: https://right/en-US/account/logout " & _
vbNewLine & vbNewLine & _
"Many thanks and kind regards"
' .send
.Display
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Application.SendKeys "+o"
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I found through further testing, that a automatic pop up appeared when the 'Send' button was clicked by this command Application.SendKeys "%s", so I added Application.SendKeys "+o2, to automatically click "OK".
Kind regards
Chris
try
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
this is of course using .Send
make sure to turn them back on at end of sub
I have this email automation program. I essentially want to create a error catch for RecpName. When RecpName is passed into Lotus Notes and returns an error (due to spelling errors), I want to capture that into a error catch.
I still want the loop to keep going and continue down the list, but tell the user which names it couldn't send emails to.
Here's my code:
Sub Send_HTML_Email()
Const ENC_IDENTITY_8BIT = 1729
'Send Lotus Notes email containing links to files on local computer
Dim NSession As Object 'NotesSession
Dim NDatabase As Object 'NotesDatabase
Dim NStream As Object 'NotesStream
Dim NDoc As Object 'NotesDocument
Dim NMIMEBody As Object 'NotesMIMEEntity
Dim SendTo As String
Dim subject As String
Dim HTML As String, HTMLbody As String
Dim wb As Workbook
Dim ws As Worksheet
Dim lstrow As Long, j As Long
Dim RecpName As String, candiName As String
Dim a As Hyperlink
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Detail")
' Instantiate the Lotus Notes COM's Objects.
lstrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set NSession = CreateObject("Notes.NotesSession") 'using Lotus Notes Automation Classes (OLE)
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
For j = 3 To lstrow
RecpName = ws.Cells(j, 2).Text
candiName = ws.Cells(j, 1).Text
SendTo = RecpName
subject = wb.Worksheets("Email Settings").Range("B1").Text
Debug.Print subject
Set NStream = NSession.CreateStream
HTMLbody = "<p>" & "Hi " & ws.Cells(j, 2).Text & "," & "</p>" & _
vbCrLf & _
"<p>" & Sheets("Email Settings").Cells(2, 2).Text & vbCrLf & _
Sheets("Detail").Cells(j, 1).Text & "</p>" & vbCrLf & _
"<p>" & Sheets("Email Settings").Cells(3, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(4, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(5, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(6, 2).Text & "</p>" & _
"<p>" & Sheets("Email Settings").Cells(9, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(10, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(11, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(12, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(13, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(14, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(15, 2).Text & "</p>"
HTML = "<html>" & vbLf & _
"<head>" & vbLf & _
"<meta http-equiv=""Content-Type"" content=""text/html; charset=UTF-8""/>" & vbLf & _
"</head>" & vbLf & _
"<body>" & vbLf & _
HTMLbody & _
"</body>" & vbLf & _
"</html>"
NSession.ConvertMime = False 'Don't convert MIME to rich text
Set NDoc = NDatabase.CreateDocument()
With NDoc
.Form = "Memo"
.subject = subject
.SendTo = Split(SendTo, ",")
Set NMIMEBody = .CreateMIMEEntity
NStream.WriteText HTML
NMIMEBody.SetContentFromText NStream, "text/html; charset=UTF-8", ENC_IDENTITY_8BIT
.Send False
.Save True, False, False
End With
NSession.ConvertMime = True 'Restore conversion
Next j
Set NDoc = Nothing
Set NSession = Nothing
MsgBox "The e-mail has successfully been created and distributed", vbInformation
End Sub
Maybe this code can help you:
Sub Send_HTML_Email()
Dim cnt_err As Integer: cnt_err = 1
On Error GoTo ErrorHandler
Const ENC_IDENTITY_8BIT = 1729
' Insert the rest of the code here
MsgBox "The e-mail has successfully been created and distributed", vbInformation
Exit Sub
ErrorHandler:
' Insert code to handle the error, e.g.
wb.Worksheets("SheetToSaveMailsNotSent").Range("A" & cnt) = RecpName
cnt = cnt + 1
' The next instruction will continue the subroutine execution
Resume Next
End Sub
For more help you can go to this link.
HTH ;)
I have a created a macro for my spreadsheet which can sent out emails successfully.
However, it can only send e-mails of each individual part numbers which are over the due date. Which means if I have 100 over the due date part numbers, there will be 100 emails being sent out.
I would like my macro to send the email by a range of cells which are of similar product (eg. printer) and are over the due date. There can be other products like laptop, camera, webcam as well. I need to do this as i don't want to spam the receiver's inbox.
How do I do that?
Sub LabelArtworkRelease()
Dim OutApp As Object
Dim Message1 As Object
Dim cell As Range
Dim emailBody As String
Dim Signature As String
'GET DEFAULT EMAIL SIGNATURE
Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
Signature = Signature & Dir$(Signature & "*.htm")
Else:
Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
'End
Application.ScreenUpdating = False
'Create a new Outlook session
Set appOutlook = CreateObject("Outlook.Application")
On Error GoTo cleanup
'Declare header variables
partnumber = Range("A3").Value
productfamily = Range("B3").Value
desc = Range("C3").Value
artworkactual = Range("F3").Value
artworkexpected = Range("G3").Value
remark = Range("L3").Value
On Error Resume Next
'if artwork actual date is later than artwork expected date
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If Cells(cell.Row, "G").Value < Cells(cell.Row, "F").Value And Cells(cell.Row, "L").Value = "Incomplete" Then
'Create a new message
Set Message1 = appOutlook.CreateItem(olMailItem)
'Create default message
emailBody = "<Font face=Calibri>Hi " & Cells(cell.Row, "D").Value & " , <p>" _
& "Please be reminded that the following part numbers - is/are over the expected artwork release date. <p> Kindly act on the following item(s): <br> " _
& "<table border=1><tr><th>" _
& partnumber & "</th>" _
& "<th>" & productfamily & "</th>" _
& "<th>" & desc & "</th>" _
& "<th>" & artworkactual & "</th>" _
& "<th>" & artworkexpected & "</th>" _
& "<th>" & remark & "</th>" _
& "<tr>" _
& "<td>" & Cells(cell.Row, "A").Value & "</td>" _
& "<td>" & Cells(cell.Row, "B").Value & "</td>" _
& "<td>" & Cells(cell.Row, "C").Value & "</td>" _
& "<td>" & Cells(cell.Row, "F").Value & "</td>" _
& "<td>" & Cells(cell.Row, "G").Value & "</td>" _
& "<td>" & Cells(cell.Row, "L").Value & "</td></tr></table><br /></font>" & Signature
With Message1
.to = "email#email.com"
.CC = Cells(cell.Row, "N") & ";" & Cells(cell.Row, "O")
.Subject = "Reminder for Label Artwork Tracking (Artwork Expected Date) - Product Family (" & Cells(cell.Row, "B").Value & ")"
.HTMLBody = emailBody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
First you can alphabetically sort the column with Product names and then within if statement you put a condition like:
If Cells(cell.Row, "Product name column").Value <> Cells(cell.Row + 1, "Product name column").Value then
So macro runs the rest of the code only after reaching the last item with the same name.
When I run the following sub, the gmail is sent without the attachment. If I set a variable for the attachment, and alter the .AddAttachment statement to .AddAttachment (FName), an attachment is sent with the email but it is empty. Please help. Here is my code:
Sub SendEmail()
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim Msg As String
Dim iBp As CDO.IBodyPart
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
= "stmpCorpServer"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = _
InputBox("Please enter your email address")
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = _
InputBox("Please enter your password")
.Update
End With
'Set Variables
Msg = "Record Count - " & EmlRcrdCt & vbNewLine & _
"Store Count - " & EmlStrCt & vbNewLine & _
"Record Count for shelf on hand > 6*+1 shelf capacity - " & _
EmlRcrdCtShlf6 & vbNewLine & _
"Record count for shelf on hand > 0 and capacity 0 - " & _
EmlRcrdCtShlf0 & vbNewLine & _
"Record count for quantity of adjustment=0 and adjustment quantity>0 - " & _
EmlRcrdQty0 & vbNewLine & _
"Record count for quantity of adjustment>0 and adjustment quantity=0 - " & _
EmlRcrdCtQtyGrtr0 & vbNewLine & vbNewLine & _
"Attached is a spreadsheet of the 'store' counts and 'shelf on hand' counts." & _
vbNewLine & _
"Please let me know if you have any questions." & vbNewLine & vbNewLine & _
EmlMisStrs & vbNewLine & _
EmlLgVar & vbNewLine
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Set email settings
On Error Resume Next
With iMsg
Set .Configuration = iConf
.To = "MyEmail"
.From = """Julia"" <MyEmail>"
.CC = "MyEmail"
.BCC = ""
.Subject = "CAO results for week ending " & LstDayInWk
.TextBody = Msg
.AddAttachment "C:\CAO\SS CAO we 06072014.xlsx"
.Send
End With
On Error GoTo 0
'Activate Control Sheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
End Sub