Bulk Emails with multiple variations

[ComputerNewbie1992]

Hi All,

I have an idea of what I would like the spreadsheet to do however I have ZERO experience with VBA or coding and I've relied heavily on formulas in the past. I've created an example spreadsheet to try to explain what I'm trying to achieve but basically, I'm looking for a spreadsheet which works as follows:

• Tick boxes of companies you want to send email to - if multiple are ticked, then multiple emails will be sent.
• 'Point of Contact' and 'Date' will be referred to in the email body.
• Press [Send] will provide a draft email which can be checked before sending.
  (In the past I've been unable to populate my default signature, as this will be utilised by different members of my team, I cannot have the signature as part of the email body)

Sorry I can't upload a Mini-sheet as my companies admin permissions are restrictive but I can send a copy of the spreadsheet via email if it'll be helpful.

Thanks in advance
Greg

To:	[Emails addresses associated with Company #]
Cc:	Boss@outlook.com
Subject:	[Generated from Cell]
Email Body:	Hi [Point of Contact], We wanted to let you know about an exciting product which we are looking to release to the market. Please provide your RSVP by [Date] to register your interest Regards [Signature]

 

[ComputerNewbie1992]

Those details come from cells within the sheet so I would guess that the layout of the form isnt as you first posted (I can see it has shifted by 1 cell on each post). Rather than back and forth supply the following info and I will amend the code.

Cell reference for PoC
Cell Reference for the first cell of your email body

Thanks, sorry for the back and forth.

Cell reference for PoC - Starts at F10 ends at F57
Cell Reference for the first cell of your email body - C4

 

[gordsky]

Thanks, sorry for the back and forth.

Cell reference for PoC - Starts at F10 ends at F57
Cell Reference for the first cell of your email body - C4

that's why the code is failing, those references are nothing like the sample provided. In order to provide the correct response you would need to add the workbook so the code can be amended properly. Alternatively you can try amending the code yourself so that

.HTMLBody = rng.Offset(, 3) & "<br><br>" & range("B15").value  <-- B15 needs to reflect the cell where the words "We wanted to let you know" are located

If your Poc starts at F10 the presumably your company will also be in the same row at C10 so the code will need to reflect that in the line "For each cell in range"

 

[ComputerNewbie1992]

that's why the code is failing, those references are nothing like the sample provided. In order to provide the correct response you would need to add the workbook so the code can be amended properly. Alternatively you can try amending the code yourself so that

.HTMLBody = rng.Offset(, 3) & "<br><br>" & range("B15").value  <-- B15 needs to reflect the cell where the words "We wanted to let you know" are located

If your Poc starts at F10 the presumably your company will also be in the same row at C10 so the code will need to reflect that in the line "For each cell in range"

Example (GW).xlsm
	B	C	D	E	F	G	H	I	J
2	Email Subject:	New release coming soon
3
4	Email Body:	[Test]
5
6
7
8	Whole Market?	Specific Markets
9
10	Company A	x		PoC	Mark				Company A
11	Company B			PoC	Steve				CompanyA1@outlook.com
12	Company C			PoC	Team				CompanyA2@outlook.com
13	Company D			PoC	Team
14	Company E			PoC	Team
15	Company F			PoC	Jane
16	Company G			PoC	Team
17	Company H			PoC	Team
18	Company I			PoC	Team				Company B
19	Company J			PoC	Team				CompanyB1@outlook.com
20	Company K			PoC	Team				CompanyB2@outlook.com
21	Company L			PoC	Team
22	Company M			PoC	Team
23	Company N			PoC	Team
24	Company O			PoC	Team
25	Company P			PoC	Team
26	Company Q			PoC	Team				Company C
27	Company R			PoC	Team				CompanyC1@outlook.com
28	Company S			PoC	Team				CompanyC2@outlook.com
29	Company T			PoC	Team
30	Company U			PoC	Team
31	Company V			PoC	Team
32	Company W			PoC	Team
33	Company X			PoC	Team
34	Company Y			PoC	Team				Company D
35	Company Z			PoC	Team				CompanyD1@outlook.com
36	Company AA			PoC	Team				CompanyD2@outlook.com
37	Company AB			PoC	Team
38	Company AC			PoC	Team
39	Company AD			PoC	Team
40	Company AE			PoC	Team
41	Company AF			PoC	Team
42	Company AG			PoC	Team				Company E
43	Company AH			PoC	Team				CompanyE1@outlook.com
44	Company AI			PoC	Team				CompanyE2@outlook.com
45	Company AJ			PoC	Team
46	Company AK			PoC	Team
47	Company AL			PoC	Team
48	Company AM			PoC	Team
49	Company AN			PoC	Team
50	Company AO			PoC	Team				Company F
51	Company AP			PoC	Team				CompanyF1@outlook.com
52	Company AQ			PoC	Team				CompanyF2@outlook.com
53	Company AR			PoC	Team
54	Company AS			PoC	Team
55	Company AT			PoC	Team
56	Company AU			PoC	Team
57	Company AV			PoC	Team
58									Company G
59									CompanyG1@outlook.com
60									CompanyG2@outlook.com
61
Email list

Cell Formulas
Range	Formula
C11:C57	C11	=IF($C$8="Full Market","x","")

Cells with Data Validation
Cell	Allow	Criteria
C8:E8	List	Full Market, Specific Markets
C10:C57	List	x,

------------------

Sub CreateEmails()
Application.ScreenUpdating = False
Dim OutApp As Object, OutMail As Object, rng As Range, fnd As Range, x As Long, Signature As String
Set OutApp = CreateObject("Outlook.Application")
For Each rng In Range("C10", Range("C" & Rows.Count).End(xlUp))
If rng = "x" Then
Set fnd = Range("J:J").Find(rng.Offset(, -1).Value, LookIn:=xlValues, lookat:=xlWhole)
If Not fnd Is Nothing Then
x = fnd.CurrentRegion.Offset(1).Cells.Count - 1
Set OutMail = OutApp.CreateItem(0)
With OutMail
.display
Signature = OutMail.HTMLbody
.To = Join(Application.WorksheetFunction.Transpose(Range("J" & fnd.Row + 1).Resize(x).Value), ";")
.cc = "Boss@outlook.com"
.Subject = Range("C2").Value
.HTMLbody = .HTMLbody = rng.Offset(, 3) & "<br><br>" & "We wanted to let you know about an exciting product which we are looking to release to the market." & "<br><br><br><br>" & "Regards,"
.HTMLbody = .HTMLbody & Signature
.display
End With
End If
End If
Next rng
Application.ScreenUpdating = True
End Sub

 

[gordsky]

The below code works exactly as you want based on the sheet you supplied above. If you re arrange it or move anything around you will need to alter the vba code reference to it. The reason I think it was failing before is because you had double up on the "=" on the line below your subject.
Incidentally if specific market is selected and you then select any cell from C11 downwards with an x you will be overwriting your cell formula. You may be better setting that as a conditional format.

Heres your code

Sub CreateEmails()

Application.ScreenUpdating = False

Dim OutApp As Object, OutMail As Object
Dim rng As range, fnd As range
Dim x As Long
Dim Signature As String

Set OutApp = CreateObject("Outlook.Application")

For Each rng In range("C10", range("C" & Rows.Count).End(xlUp))
    
    If rng = "x" Then

    Set fnd = range("J:J").Find(rng.Offset(, -1).Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then

        x = fnd.CurrentRegion.Offset(1).Cells.Count - 1

        Set OutMail = OutApp.CreateItem(0)
            With OutMail
              .display
              Signature = OutMail.HTMLbody
              .To = Join(Application.WorksheetFunction.Transpose(range("J" & fnd.Row + 1).Resize(x).Value), ";")
              .cc = "Boss@outlook.com"
              .Subject = range("C2").Value
              .HTMLbody = "Hi " & rng.Offset(, 3) & "," & "<br><br>" & range("C4") & "<br><br><br><br>" & "Regards,"
              .HTMLbody = .HTMLbody & Signature
              .display
            End With
        End If
    End If

Next rng

Application.ScreenUpdating = True
End Sub

 

[ComputerNewbie1992]

The below code works exactly as you want based on the sheet you supplied above. If you re arrange it or move anything around you will need to alter the vba code reference to it. The reason I think it was failing before is because you had double up on the "=" on the line below your subject.
Incidentally if specific market is selected and you then select any cell from C11 downwards with an x you will be overwriting your cell formula. You may be better setting that as a conditional format.

Heres your code

Sub CreateEmails()

Application.ScreenUpdating = False

Dim OutApp As Object, OutMail As Object
Dim rng As range, fnd As range
Dim x As Long
Dim Signature As String

Set OutApp = CreateObject("Outlook.Application")

For Each rng In range("C10", range("C" & Rows.Count).End(xlUp))
   
    If rng = "x" Then

    Set fnd = range("J:J").Find(rng.Offset(, -1).Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then

        x = fnd.CurrentRegion.Offset(1).Cells.Count - 1

        Set OutMail = OutApp.CreateItem(0)
            With OutMail
              .display
              Signature = OutMail.HTMLbody
              .To = Join(Application.WorksheetFunction.Transpose(range("J" & fnd.Row + 1).Resize(x).Value), ";")
              .cc = "Boss@outlook.com"
              .Subject = range("C2").Value
              .HTMLbody = "Hi " & rng.Offset(, 3) & "," & "<br><br>" & range("C4") & "<br><br><br><br>" & "Regards,"
              .HTMLbody = .HTMLbody & Signature
              .display
            End With
        End If
    End If

Next rng

Application.ScreenUpdating = True
End Sub

Amazing, thanks so much!

 

[gordsky]

Amazing, thanks so much!

if it does what you need could you mark the thread as solved