can anyone explain to me the proper way to loop a certain range? I do not understand this part on how to make this work please? How do I do this only from row 2 to 4? It has a compile error, loop without for, any idea how to amend this please
Sub send_mass_email_display_only()
Dim i As Integer
Dim name As String, email As String, body As String, subject As String, copy As String, pdfadd As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
For i = 2 To 4
'Loop down name column starting at row 2 column 1
Do While Cells(i, 1).Value <> ""
name = Split(Cells(i, 1).Value, " ")(0)
'name = Cells(i, 1).Value
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
pdfadd = Cells(i, 5).Value
body = Replace(body, "C1", name)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = email
.cc = copy
.subject = subject
.body = body
.Attachments.Add (pdfadd)
.display
'.Send
End With
body = ActiveSheet.TextBoxes("TextBox 1").Text 'reset body text
Next i
Set OutMail = Nothing
Set OutApp = Nothing
'MsgBox "Email(s) Sent!"
End Sub
I tried as FaneDuru/grayProgrammerz suggested to delete the Do While line... seems that this works so far
Option Explicit
Sub send_mass_email_display_only()
Dim i As Integer
Dim name As String, email As String, body As String, subject As String, copy As String, pdfadd As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
For i = 2 To 4
'Specific rows
name = Split(Cells(i, 1).Value, " ")(0)
'name = Cells(i, 1).Value
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
pdfadd = Cells(i, 5).Value
body = Replace(body, "C1", name)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = email
.cc = copy
.subject = subject
.body = body
.Attachments.Add (pdfadd)
.display
'.Send
End With
body = ActiveSheet.TextBoxes("TextBox 1").Text 'reset body text
Next i
Set OutMail = Nothing
Set OutApp = Nothing
'MsgBox "Email(s) Sent!"
End Sub
Related
Seems that i can't add the text while adding the signature in the same code. Below you may see it:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.body = body
.HTMLbody = sig
That HTMLbody is deleting the body that i have 1 row up in the formula.
I have tryed to modify as i saw in other examples here, but nothing seems to work.Bellow you can see also the whole project.
Can you check and let me know were i have faild?
Sub send_mass_email()
Dim i As Integer
Dim name, email, body, subject, copy, place, business As String
Dim OutApp As Object
Dim OutMail As Object
Dim fsFile As Object
Dim fso As Object
Dim fsFolder As Object
Dim strFolder As String
Dim sig As String
sig = ReadSignature("adi.htm")
HTMLbody = ActiveSheet.TextBoxes("TextBox 1").Text
i = 2
'Loop down name column starting at row 2 column 1
Do While Cells(i, 1).Value <> ""
name = Split(Cells(i, 1).Value, " ")(0) 'extract first name
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
business = Cells(i, 5).Value
answ = MsgBox("what it need to be attach " & Cells(i, 1) & " ?", vbYesNo + vbExclamation, "PSK Check")
If answ <> vbYes Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.HTMLbody = body
.HTMLbody = sig
.display
End With
End If
If answ = vbYes Then
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
If xFileDlg.Show = -1 Then
'replace place holders
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.HTMLbody = body & sig
.display
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
'.Send
End With
End If
'reset body text
body = ActiveSheet.TextBoxes("TextBox 1").Text
End If
i = i + 1
Loop
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try replacing these two lines...
.HTMLbody = body
.HTMLbody = sig
with
.HTMLbody = body & sig
By the way, if you want a line break between the body and signature, try the following instead...
.HTMLbody = body & "<br>" & sig
I contact several colleagues across different departments and due to compliance the default email signature is to be used on all emails.
I managed to produce a blanket email, using Excel VBA, that has the same body across all emails with changes based on the staff's location and criteria.
My signature is not populated.
Sub send_mass_email()
Dim i As Integer
Dim Greeting, email, body, subject, business, Website As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = 2
Do While Cells(i, 1).Value <> ""
Greeting = Cells(i, 2).Value
email = Cells(i, 3).Value
body = ActiveSheet.TextBoxes("TextBox 1").Text
subject = Cells(i, 4).Value
business = Cells(i, 1).Value
Website = Cells(i, 5).Value
' replace place holders
body = Replace(body, "B2", Greeting)
body = Replace(body, "A2", business)
body = Replace(body, "E2", Website)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.subject = subject
.body = body & Signature
'.Attachments.Add ("") 'You can add files here
.display
'.Send
End With
'reset body text
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = i + 1
Loop
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Sent!"
End Sub
Call the Display method before making any body-related modifications to generate/add the default signature in the message body:
With OutMail
.display
.to = email
.subject = subject
'.body = body & Signature
'.Attachments.Add ("") 'You can add files here
'.Send
End With
I am running a simple process that loops through a sheet and send an email based on Name, Email, Subject, CC and Country as shown in the image.
The image is only showing row 5 and 10 but the macro is running all rows from 2 to 10 and generates 9 email drafts instead of 2 email drafts.
May I know how to only run the loop on existing rows in the sheet?
Sub send_mass_email()
Dim i As Integer
Dim name, email, body, subject, copy, place, business As String
Dim OutApp As Object
Dim OutMail As Object
Dim cel As Range
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = 2
'Loop down name column starting at row 2 column 1
Do While Cells(i, 1).Value <> ""
name = Split(Cells(i, 1).Value, " ")(0) 'extract first name
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
business = Cells(i, 5).Value
place = Cells(i, 6).Value
'replace place holders
body = Replace(body, "C1", name)
body = Replace(body, "C5", business)
body = Replace(body, "C6", place)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.body = body
'.Attachments.Add ("") 'You can add files here
.display
'.Send
End With
'reset body text
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = i + 1
Loop
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Created!"
End Sub
Add an IF THEN in your Loop to check if the row is hidden or not. If true, do nothing:
Do While Cells(i, 1).Value <> ""
If Cells(i, 1).EntireRow.Hidden = False Then
'rest of your code
'
'
'
'
End If
i = i + 1
Loop
When filtering a range, those rows are hidden, so their property Hidden becomes True. If False it means those are the visible rows where you want to send email.
This file pulls in the different pieces of information
.
The textbox in the code shows what the email will look like before the code runs.
When I try to send the email, the error is
"Loop without Do"
As well how do I allow for multiple addresses per email (Email1,email2,email3). Currently the code only pulls in Email1.
Sub send_mass_email()
Dim i As Integer
Dim name, Email, Email2, Email3, GMEmail, body, subject, MTDRev, LMRev, SYSRevGrowth, MTDNMU, LMNMU, NMUChange, MTDLeads, LMLeads, LeadsChange, OSAvg, AvgNMU, AvgActivityMTD As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = 2
Do While Cells(i, 1).Value <> ""
name = Range("B2").Value
Email = Range("C2").Value
Email2 = Range("D2").Value
Email3 = Range("E2").Value
GMEmail = Range("F2").Value
body = ActiveSheet.TextBoxes("TextBox 1").Text
subject = Range("G2").Value
MTDRev = Range("H2").Value
LMRev = Range("I2").Value
SYSRevGrowth = Range("J2").Value
MTDNMU = Range("K2").Value
LMNMU = Range("L2").Value
NMUChange = Range("M2").Value
MTDLeads = Range("N2").Value
LMLeads = Range("O2").Value
LeadsChange = Range("P2").Value
OSAvg = Range("Q2").Value
AvgNMU = Range("R2").Value
AvgActivityMTD = Range("S2").Value
body = Replace(body, "B2", name) & "font.color=red"
body = Replace(body, "H2", MTDRev)
body = Replace(body, "I2", LMRev)
body = Replace(body, "J2", SYSRevGrowth)
body = Replace(body, "K2", MTDNMU)
body = Replace(body, "L2", LMNMU)
body = Replace(body, "M2", NMUChange)
body = Replace(body, "N2", MTDLeads)
body = Replace(body, "O2", LMLeads)
body = Replace(body, "P2", LeadsChange)
body = Replace(body, "Q2", OSAvg)
body = Replace(body, "R2", AvgNMU)
body = Replace(body, "S2", AvgActivityMTD)
body = Replace(body, "X2", Title)
body = Replace(body, "Y2", Date)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = Email
.to = Email2
.to = Email3
.to = GMEmail
.subject = subject
.body = body
'.Attachments.Add ("") 'You can add files here
.Display
'.Send
body = ActiveSheet.TextBoxes("TextBox 1").Text 'reset body text
i = i + 1
Loop
End If
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Sent!"
End Sub
Untested but this should get you closer:
Sub send_mass_email()
Dim i As Integer, ws As Worksheet, col, c As Range
Dim OutApp As Object, body As String, sTo As String
Dim OutMail As Object
Set ws = ActiveSheet
i = 2
Do While ws.Cells(i, 1).Value <> ""
body = ws.TextBoxes("TextBox 1").Text & "font.color=red" '??
'loop over the 3 potential address cells and concatenate any content
For Each c In ws.Cells(i, "C").Resize(1, 3).Cells
If Len(c.Value) > 0 Then
sTo = sTo & IIf(Len(sTo) > 0, ";", "") & c.Value 'build the "to" string
End If
Next c
'you can skip all those intermediate variables and replace directly
For Each col In Array(Split("B,H,I,J,K,L,M,N,O,P,Q,R,S,X,Y", ",")) 'loop array of column letters
body = Replace(body, col & "2", ws.Cells(i, col).Value) 'replace tokens in body
Next col
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = sTo
.subject = ws.Cells(i, "G").Value
.body = body
'.Attachments.Add ("") 'You can add files here
.Display
'.Send
End With
i = i + 1
Loop
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Sent!"
End Sub
I have a create a bit of dynamic email where user is able to send multiple email based on how many data in the said column. The code itself will follow the textbox word by word and generate in the email body, but I am currently trying to make Excel open an Email Meeting template instead of a normal email.
Here is the code.
Sub send_mass_email()
Dim i As Integer
Dim name, email, body, subject, copy, place, business As String
Dim OutApp As Object
Dim OutMail As Object
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = 2
'Loop down name column starting at row 2 column 1
Do While Cells(i, 1).Value <> ""
name = Split(Cells(i, 1).Value, " ")(0) 'extract first name
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
business = Cells(i, 5).Value
place = Cells(i, 6).Value
'replace place holders
body = Replace(body, "C1", name)
body = Replace(body, "C5", business)
body = Replace(body, "C6", place)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.body = body
'.Attachments.Add ("") 'You can add files here
.display
'.Send
End With
'reset body text
body = ActiveSheet.TextBoxes("TextBox 1").Text
i = i + 1
Loop
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Sent!"
End Sub
I have tried to use olmeeting but an error occurs: Object doesn't support this property or method .
There are no silly questions!
Please reference the VBA documentation here.
It seems that you want to modify this part of the code:
Set OutMail = OutApp.CreateItem(0)
to
Set OutMail = OutApp.CreateItem(1)
The documentation imples that by changing the parameter of .CreateItem method to one of the listed values here, you will achieve the desired effect. Please note I did not yet test it.