panidziobak
04-21-2020, 02:15 AM
Hello everyone,
I am writing from Spain with a little problem that I have in my macro. I have to admit that I am still learning the VBA by trying different solutions from various forums but some things are misterious for me.
My project is a macro to automatically send emails based on the defined table with data - this table is included in the body of the email. My macro works perfectly until one point: I am able to send emails to a defined list of recipients filtering the table of data by creating a list of items - name of the recipient. Sadly I have to include another condition to the filter which has to define a type of the message to be send. Therefore I would have to create two filters to have two levels of list of contents. As in below picture, the first level of the list of contents is the column "F" - name of the location/recipient and second is the column "N" the type of the message.
https://i.stack.imgur.com/Tu2Ri.png (https://i.stack.imgur.com/Tu2Ri.png)
So for each of the location in column "F" there are actually 3 types of message to be sent that can be placed in column "N".
https://i.stack.imgur.com/JopK5.png (https://i.stack.imgur.com/JopK5.png)
Below you can take a look at the macro that works fine for sending emails with only filtering by the location name.
Sub SendMail()
Dim OutApp As Object
Dim OutMail As Object
Dim list As Object, item As Variant
Set list = CreateObject("System.Collections.ArrayList")
Dim rng As Range
Dim StrBodyStart As String
Dim StrBodyEnd As String
With Hoja7
For Each item In .Range("F2", .Range("F" & .Rows.Count).End(xlUp))
If Not list.Contains(item.Value) Then list.Add item.Value
Next
End With
For Each item In list
Sheets("Destino").Select
ActiveSheet.Range("$A:$F").AutoFilter Field:=6, Criteria1:=item
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Set rng = Selection
'I need the macro to copy the item to another Sheet("Contactos") this is where I cross the information of the location name with corresponding email address - preferably the type of the message would be copied to cell C1 in sheet "Contactos".
Sheets("Contactos").Select
If IsNull(item) Then Worksheets("Contactos").Range("A1").Value = 0 Else
Worksheets("Contactos").Range("A1").Value = item
'Create email in Outlook
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.logon
Set OutMail = OutApp.CreateItem(0)
'These are two parts of the message that are going to be copied to the Outlook email
StrBodyStart = Worksheets("Contactos").Range("D1").Value
StrBodyEnd = Worksheets("Contactos").Range("E1").Value
With OutMail
.To = Worksheets("Contactos").Range("B1").Value
.CC = Worksheets("Contactos").Range("F1").Value
.Subject = "Test email " & item & Format(Date, " ddmmyyyy")
.HTMLBody = StrBodyStart & RangetoHTML(rng) & StrBodyEnd
.Send
End With
On Error GoTo 0
Set rng = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
Next
ThisWorkbook.Save
End Sub
Function RangetoHTML(rng As Range)
'This function copies the table of data to use it for the message.
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 paste 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:publishsource=", _
"align=left x:publishsource=")
'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
I already have the matrix of contacts with the types of messages to match but I canīt make the macro work properly :(
If you guys have any suggestions on how to create a second level of the list here I would be more than grateful. I will keep on investigating and if something comes up, I will update the post. Thank you very much in advance and have a great day.
I am writing from Spain with a little problem that I have in my macro. I have to admit that I am still learning the VBA by trying different solutions from various forums but some things are misterious for me.
My project is a macro to automatically send emails based on the defined table with data - this table is included in the body of the email. My macro works perfectly until one point: I am able to send emails to a defined list of recipients filtering the table of data by creating a list of items - name of the recipient. Sadly I have to include another condition to the filter which has to define a type of the message to be send. Therefore I would have to create two filters to have two levels of list of contents. As in below picture, the first level of the list of contents is the column "F" - name of the location/recipient and second is the column "N" the type of the message.
https://i.stack.imgur.com/Tu2Ri.png (https://i.stack.imgur.com/Tu2Ri.png)
So for each of the location in column "F" there are actually 3 types of message to be sent that can be placed in column "N".
https://i.stack.imgur.com/JopK5.png (https://i.stack.imgur.com/JopK5.png)
Below you can take a look at the macro that works fine for sending emails with only filtering by the location name.
Sub SendMail()
Dim OutApp As Object
Dim OutMail As Object
Dim list As Object, item As Variant
Set list = CreateObject("System.Collections.ArrayList")
Dim rng As Range
Dim StrBodyStart As String
Dim StrBodyEnd As String
With Hoja7
For Each item In .Range("F2", .Range("F" & .Rows.Count).End(xlUp))
If Not list.Contains(item.Value) Then list.Add item.Value
Next
End With
For Each item In list
Sheets("Destino").Select
ActiveSheet.Range("$A:$F").AutoFilter Field:=6, Criteria1:=item
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Set rng = Selection
'I need the macro to copy the item to another Sheet("Contactos") this is where I cross the information of the location name with corresponding email address - preferably the type of the message would be copied to cell C1 in sheet "Contactos".
Sheets("Contactos").Select
If IsNull(item) Then Worksheets("Contactos").Range("A1").Value = 0 Else
Worksheets("Contactos").Range("A1").Value = item
'Create email in Outlook
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.logon
Set OutMail = OutApp.CreateItem(0)
'These are two parts of the message that are going to be copied to the Outlook email
StrBodyStart = Worksheets("Contactos").Range("D1").Value
StrBodyEnd = Worksheets("Contactos").Range("E1").Value
With OutMail
.To = Worksheets("Contactos").Range("B1").Value
.CC = Worksheets("Contactos").Range("F1").Value
.Subject = "Test email " & item & Format(Date, " ddmmyyyy")
.HTMLBody = StrBodyStart & RangetoHTML(rng) & StrBodyEnd
.Send
End With
On Error GoTo 0
Set rng = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
Next
ThisWorkbook.Save
End Sub
Function RangetoHTML(rng As Range)
'This function copies the table of data to use it for the message.
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 paste 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:publishsource=", _
"align=left x:publishsource=")
'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
I already have the matrix of contacts with the types of messages to match but I canīt make the macro work properly :(
If you guys have any suggestions on how to create a second level of the list here I would be more than grateful. I will keep on investigating and if something comes up, I will update the post. Thank you very much in advance and have a great day.