Good Morning,
I have a spreadsheet consisting of 2 tabs.
First tab is called "MM" - this consists of a table, 2 columns by 13 rows with several rows below consisting of a few sentences. The table could increase to 4 or 6 columns but will always be 13 rows.
| Legal Name | Stephen Preece |
| Other Name | TEST |
| Code | TEST |
| Bank | TEST |
| Value | TEST |
| Domicile | TEST |
| Type | TEST |
| Date | TEST |
| Instructions | TEST |
| Details | TEST |
| Address | TEST |
| Admin | TEST |
| List | TEST |
Second tab is called "Contacts MM" - this consists of 3 columns A, B & C where:
Column A shows names of individuals
Column B shows either "Yes" or "No"
Column C shows email address which may have one email or several emails on the same line semi colon delimited.
A B C
| Joe Bloggs | No | email address; |
| Michael Smith | Yes | email address; |
| Stephen Preece | Yes | email address; email address; |
What I would like to do is have some VBA code to go through column B and all the rows that have a "Yes" take the email addresses in column C and create just the one email and add all the email addresses to .BCC
Then take the information in the First tab "MM" and add it to the body of the email
Can you help please?
Thank you in advance
Stephen
Morning Anyone,
I forgot to post the code I have already which works but loads a new email every time column B has a "Yes". I only want one email created with all the email addresses relating to column B, so in the example above it would be .BCC email address; email address; email address;
Can someone help?
Sub MM()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim str1, str2, str3 As String
Dim subj As String
Dim Worksheet As Range
Dim ThisWorkbook As Object
Dim sMail_ids As String
Dim sMail_ids2 As String
'Look in column B2 onward, where Yes/No would reside
LastRow = Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If UCase(Cells(i, 2).Value) = "YES" Then
'Address is offset 1 row above
emailTo = Cells(i, 2 + 1).Value
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("Money Market").Range("B10:C22").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
str1 = "<Body style = font-size:11pt;font-family:Calibri>" & _
"<br>TEST"
str2 = "<br>TEST"
str3 = "<br>TEST"
'Dim OutApp As Object
'Dim OutMail As Object
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = emailTo
.Subject = subj
.HTMLBody = str1 & RangetoHTML(rng) & str2 & .HTMLBody
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
'Cells(i, 2).value = "No"
Next
End Sub
Function RangetoHTML(rng As Range)
'
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).openastextstream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x
ublishsource=", _
"align=left x
ublishsource=")
'Close TempWB
TempWB.Close SaveChanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
