I have the following code where the adress doen't work... I wonder how I can select the e-mail adress value out of a cell because with cells(1,1).value it doesn't seem to work in my case.
Sub email_missing_forecast()
Application.ScreenUpdating = False
'Déclaration des variables
derniereligne = Range("B").End(xlUp).Row
Adresse = Cells(i, "D").Value
Adresse2 = Cells(i, "E").Value
Adresse3 = Cells(i, "F").Value
Project_number = Cells(1, 2).Value
Project_name = Cells(2, 2).Value
Project_due = Cells(3, 2).Value
Lien = Cells(4, 2).Value
Dim Objoutlook As New Outlook.Application
Dim Objectmail
'Condition
For i = 6 To derniereligne
If Cells(i, "B").Value = "No" Then
Set Objoutlook = New Outlook.Application
Set Objectmail = Outlook.createitem(olmailitem)
With Objectmail
.To = Adresse & ";" & Adresse2 & ";" & Adresse3
.Subject = "Bobbi Brown| " & Project_number & " " & Project_name & "| Forecast due " & Project_due
.Body = "Dear All, " & Chr(10) & "I kindly remind you that forecasts for program " & Project_number & " " & Project_name & " are due " & Project_due & "." & Chr(10) & "Please enter your forecast " & "<a href=lien>here.</a>" & Chr(10) & "Best Regards," & Chr(10) & "Christian Chen"
.Send
End with
End If
Next i
Application.ScreenUpdating = True
MsgBox "Your e-mails have been sent successfully", , "FIY"
End Sub
You didn't set i before using it for your Adresse variables, moving the declaration of these variables in your loop should solve your problem:
Sub email_missing_forecast()
Application.ScreenUpdating = False
'Déclaration des variables
derniereligne = Range("B").End(xlUp).Row
Project_number = Cells(1, 2).Value
Project_name = Cells(2, 2).Value
Project_due = Cells(3, 2).Value
Lien = Cells(4, 2).Value
Dim Objoutlook As New Outlook.Application
Dim Objectmail
'Condition
For i = 6 To derniereligne
Adresse = Cells(i, "D").Value
Adresse2 = Cells(i, "E").Value
Adresse3 = Cells(i, "F").Value
If Cells(i, "B").Value = "No" Then
Set Objoutlook = New Outlook.Application
Set Objectmail = Outlook.createitem(olmailitem)
With Objectmail
.To = Adresse & ";" & Adresse2 & ";" & Adresse3
.Subject = "Bobbi Brown| " & Project_number & " " & Project_name & "| Forecast due " & Project_due
.Body = "Dear All, " & Chr(10) & "I kindly remind you that forecasts for program " & Project_number & " " & Project_name & " are due " & Project_due & "." & Chr(10) & "Please enter your forecast " & "<a href=lien>here.</a>" & Chr(10) & "Best Regards," & Chr(10) & "Christian Chen"
.Send
End with
End If
Next i
Application.ScreenUpdating = True
MsgBox "Your e-mails have been sent successfully", , "FIY"
End Sub
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
Is it possible to open an existing application window?
What I want:
What is the code in order to put focus on an already open, but not in focus, application. For example, with:
Set objIE = New InternetExplorer
but I want the macro to put focus on an already existing IE.
Here is another case, I let Lotus notes create an email with the following code:
Sub Email_Bot()
'variables are defined
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim Session As Object
Dim AttachME As Object
Dim EmbedObj As Object
Dim Attachment As String
Dim stAttachment As String
Dim Mail_Form As String
Dim Mail_SendTo As String
Dim Mail_Subject As String
Dim Mail_Body As String
Dim Mail_Attachement As Boolean
Dim Mail_Save As Boolean
Dim Mail_Send As Boolean
Dim Mail_Name As String
Dim Mail_Text_1 As String
Dim Mail_Text_2 As String
Dim Mail_Text_3 As String
Dim Mail_Text_4 As String
Dim Mail_Text_5 As String
Dim Mail_Text_6 As String
Dim Mail_Closing As String
Dim Mail_SendBy As String
Dim tb_Mailing_List As Object
Dim tb_Email_Template As Object
Dim LastRow As Integer
Dim Row_Count As Integer
Dim Mail_Body_Lock As Boolean
Dim Workspace As Object
Const EMBED_ATTACHMENT As Long = 1454
'worksheets are defined
Set tb_Mailing_List = ThisWorkbook.Sheets("Mailing List")
Set tb_Email_Template = ThisWorkbook.Sheets("Email Template")
'mail session is defined
Set Session = CreateObject("Notes.NotesSession")
Set Maildb = Session.CURRENTDATABASE
Set MailDoc = Maildb.CREATEDOCUMENT
Set Workspace = CreateObject("Notes.NOTESUIWORKSPACE")
'important variables are set
LastRow = tb_Mailing_List.Cells(Rows.Count, 2).End(xlUp).Row
Row_Count = 3
Mail_Body_Lock = False
'cell assignment
Mail_Text_1 = tb_Email_Template.Cells(4, 4).Value
Mail_Text_2 = tb_Email_Template.Cells(5, 4).Value
Mail_Text_3 = tb_Email_Template.Cells(6, 4).Value
Mail_Text_4 = tb_Email_Template.Cells(7, 4).Value
Mail_Text_5 = tb_Email_Template.Cells(8, 4).Value
Mail_Text_6 = tb_Email_Template.Cells(9, 4).Value
Mail_Closing = tb_Email_Template.Cells(25, 4).Value
Mail_SendBy = tb_Email_Template.Cells(12, 4).Value & vbNewLine & vbNewLine & tb_Email_Template.Cells(13, 4).Value & vbNewLine & tb_Email_Template.Cells(14, 4).Value & vbNewLine & tb_Email_Template.Cells(15, 4).Value & vbNewLine & vbNewLine & tb_Email_Template.Cells(16, 4).Value & vbNewLine & tb_Email_Template.Cells(17, 4).Value & vbNewLine & tb_Email_Template.Cells(18, 4).Value & vbNewLine & tb_Email_Template.Cells(19, 4).Value & vbNewLine & tb_Email_Template.Cells(20, 4).Value & vbNewLine & tb_Email_Template.Cells(21, 4).Value & vbNewLine & tb_Email_Template.Cells(22, 4).Value
'loops until all names have been filled
Do Until Row_Count = LastRow + 1
'Mail Dashboard
Mail_Body_Lock = False
Mail_Send = False
Mail_Form = "Memo"
Mail_Name = tb_Mailing_List.Cells(Row_Count, 2).Value
Mail_SendTo = tb_Mailing_List.Cells(Row_Count, 4).Value
Mail_Subject = tb_Email_Template.Cells(2, 4).Value
Mail_Save = True
'exit round in case the email address is not present
If Mail_SendTo = "" Then GoTo NoEmail
'if only body row 1 has text
If Mail_Text_2 = "" And Mail_Text_3 = "" And Mail_Text_4 = "" And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 and row 2 have text
If Mail_Body_Lock = False And Mail_Text_3 = "" And Mail_Text_4 = "" And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & "," & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 till row 3 have text
If Mail_Body_Lock = False And Mail_Text_4 = "" And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 till row 4 have text
If Mail_Body_Lock = False And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & Mail_Text_4 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 till row 5 have text
If Mail_Body_Lock = False And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & Mail_Text_4 & vbNewLine & Mail_Text_5 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'in case there is an error or something
If Mail_Body_Lock = False Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & Mail_Text_4 & vbNewLine & Mail_Text_5 & vbNewLine & Mail_Text_6 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
End If
'mail build-up
MailDoc.Form = Mail_Form
MailDoc.SendTo = Mail_SendTo
MailDoc.Subject = Mail_Subject
MailDoc.Body = Mail_Body
'attachement build-up
If tb_Email_Template.Cells(28, 4) <> "" And tb_Email_Template.Cells(29, 4) <> "" Then
Attachment = tb_Email_Template.Cells(28, 4)
stAttachment = tb_Email_Template.Cells(29, 4)
Set AttachME = MailDoc.CREATERICHTEXTITEM("stAttachment")
Set EmbedObj = AttachME.EmbedObject(EMBED_ATTACHMENT, "", Attachment, "stAttachment")
End If
Call Workspace.EDITDOCUMENT(True, MailDoc).GOTOFIELD("Body")
MsgBox "Email send?"
NoEmail:
Row_Count = Row_Count + 1
Loop
'variable dump
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj = Nothing
End Sub
After:
Call Workspace.EDITDOCUMENT(True, MailDoc).GOTOFIELD("Body")
I want to VBA to open that window and not that I have to go there by myself. I am sure that there has to be a way. I used mouse movements, which worked until a colleague with a different screen res. used the program.
I am quite new to VBA and programming and taught myself so I am sorry if this is maybe a dumb question, but I couldn't find the answer so far anywhere else.
Try This way,
Public vPID As Variant
Public Sub OpenApplication()
'Launch application if not already open
If vPID = 0 Then 'Application not already open
101:
vPID = Shell("C:\Windows\system32\notepad.exe", vbNormalFocus)
Else 'Application already open so reactivate
On Error GoTo 101
AppActivate (vPID)
End If
End Sub
Because the variable vPID is stored as a project level Public Variable, its value will be retained for as long as your instance of Excel (or other Microsoft Office application) is open.
I would like to insert a link inside the body of the e-mail I am creating through excel VBA. The link changes every day so I have put its value in cells B4. However, I do not find a proper way to send the e-mail with that link.
This is the code I am using :
Public Sub email_missing_forecast()
Application.ScreenUpdating = False
'Déclaration des variables
derniereligne = Range("B5000").End(xlUp).Row
Project_number = Cells(1, 2).Value
Project_name = Cells(2, 2).Value
Project_due = Cells(3, 2).Value
Link = Cells(4, 2).Value
Dim Objoutlook As New Outlook.Application
Dim Objectmail
'Condition
For i = 6 To derniereligne
Adresse = Cells(i, "D").Value
Adresse2 = Cells(i, "E").Value
Adresse3 = Cells(i, "F").Value
If Cells(i, "B").Value = "No" Then
Set Objoutlook = New Outlook.Application
Set Objectmail = Outlook.createitem(olmailitem)
With Objectmail
.To = Adresse & ";" & Adresse2 & ";" & Adresse3
.Subject = "Bobbi Brown | " & Project_number & " " & Project_name & " | Forecast due " & Project_due
.Body = "Dear All, " & Chr(10) & Chr(10) & "I kindly remind you that forecasts for program " & Project_number & " " & Project_name & " are due " & Project_due & "." & Chr(10) & Chr(10) & "Please enter your forecast at this link below." & Chr(10) & Chr(10) & Link & Chr(10) & Chr(10) & "Best Regards," & Chr(10) & "Christian Chen"
.Send
End With
End If
Next i
Application.ScreenUpdating = True
MsgBox "Your e-mails have been sent successfully", , "FIY"
End Sub
There are only two possibilities IMHO:
the plain text Email: NO clickable link is possible
the HTML Email: clickable link is possible, well-formed HTML WITH <body> Tag is necessary!
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.
I'm trying to build a string in Excel VBA that will then be output to a Word file.
The basic strings I'm creating are working fine, but these complex strings are coming in to Word as "False" so I'm not sure what I'm doing wrong.
I'm working with Excel / Word 2013.
Example excel file and word template here:
https://dl.dropboxusercontent.com/u/5611192/Sales%20Package%20-%20Test%20for%20Word%20Proposal.xlsm
https://dl.dropboxusercontent.com/u/5611192/Proposal.docx
The strings that aren't working are built with the following loop:
With Sheet1
For RowCnt = Firstrow To Lastrow
If .Cells(RowCnt, 15).Value = "x" And .Cells(RowCnt, 13).Value = "" Then
strProducts = strProducts & .Cells(RowCnt, 2).Value & " " & .Cells(RowCnt, 8).Value & Chr(11)
ElseIf .Cells(RowCnt, 15).Value = "x" And Cells(RowCnt, 13).Value = "1" Then
strOptions1 = strOptions1 & .Cells(RowCnt, 2).Value & " " & .Cells(RowCnt, 8).Value & Chr(11)
ElseIf .Cells(RowCnt, 15).Value = "x" And .Cells(RowCnt, 13).Value = "2" Then
strOptions2 = strOptions2 & .Cells(RowCnt, 2).Value & " " & .Cells(RowCnt, 8).Value & Chr(11)
ElseIf .Cells(RowCnt, 15).Value = "x" And .Cells(RowCnt, 13).Value = "3" Then
strOptions3 = strOptions3 & .Cells(RowCnt, 2).Value & " " & .Cells(RowCnt, 8).Value & Chr(11)
ElseIf .Cells(RowCnt, 15).Value = "x" And .Cells(RowCnt, 13).Value = "4" Then
strOptions4 = strOptions4 & .Cells(RowCnt, 2).Value & " " & .Cells(RowCnt, 8).Value & Chr(11)
ElseIf .Cells(RowCnt, 15).Value = "x" And .Cells(RowCnt, 13).Value = "5" Then
strOptions5 = strOptions5 & .Cells(RowCnt, 2).Value & " " & .Cells(RowCnt, 8).Value & Chr(11)
ElseIf .Cells(RowCnt, 15).Value = "x" And .Cells(RowCnt, 13).Value = "6" Then
strOptions6 = strOptions6 & .Cells(RowCnt, 2).Value & " " & .Cells(RowCnt, 8).Value & Chr(11)
End If
Next RowCnt
End With
strProducts = strProducts & Chr(11) & Range("A47").Font.Bold = True & Chr(11) & "Purchase, including installation: " & strPrice
strOptions1 = strOptions1 & Chr(11) & Range("A47").Font.Bold = True & Chr(11) & "Purchase, including installation: " & strOption1Price
strOptions2 = strOptions2 & Chr(11) & Range("A47").Font.Bold = True & Chr(11) & "Purchase, including installation: " & strOption2Price
strOptions3 = strOptions3 & Chr(11) & Range("A47").Font.Bold = True & Chr(11) & "Purchase, including installation: " & strOption3Price
strOptions4 = strOptions4 & Chr(11) & Range("A47").Font.Bold = True & Chr(11) & "Purchase, including installation: " & strOption4Price
strOptions5 = strOptions5 & Chr(11) & Range("A47").Font.Bold = True & Chr(11) & "Purchase, including installation: " & strOption5Price
strOptions6 = strOptions6 & Chr(11) & Range("A47").Font.Bold = True & Chr(11) & "Purchase, including installation: " & strOption6Price
The solution
Taking the example of the first string:
strProducts = strProducts & Chr(11) & Range("A47").Font.Bold = True & Chr(11) & "Purchase, including installation: " & strPrice
This part is your issue:
Range("A47").Font.Bold = True
Change this to:
Iif(Range("A47").Font.Bold = True,True,False)
Similarly for the other strings.
The final code
Based on feedback from your comments your code should look like this:
strProducts = strProducts & Chr(11) & Range("A47").Value & Chr(11) & "Purchase, including installation: " & strPrice
Range("A47").Font.Bold = True