Related
I have a VBA macro to send e-mails to different recipients, but now I want to add attachments. The problem is the attachments paths are in an excel table and it varies according to the customer. I.e. customer A has 3 lines in the table, each with a different attachment, cust B has 5 lines, and so on.
Anyone knows how to vlookup it and get all possible files paths? Here follows my current code without attachments:
Sub Controle_de_orçamentos()
response = MsgBox("Deseja enviar as cobranças?", vbYesNo)
If response = vbNo Then
MsgBox ("Então tchau")
Exit Sub
End If
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0
If mailAddress <> "" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = mailAddress
.Subject = "Orçamentos aguardando aprovação - Indi Empilhadeiras"
.HTMLBody = "Prezados(as), boa tarde!<br>" & _
"Poderiam, por gentileza, informar se os orçamentos abaixo estão aprovados?" & RangetoHTML(rng) & _
"<br>Obrigado!<br>" & _
"Denis Scalco<br>" & _
"(15) 98145-0856"
.Display 'Or use Send
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
To filter the files for a specific customer you may want to use standard or advanced filtering:
https://support.microsoft.com/en-gb/office/filter-by-using-advanced-criteria-4c9222fe-8529-4cd7-a898-3f16abdff32b
read file names of attachments from range: see below code proposal
add attachments
How to add an attachment to an email using VBA in Excel
Option Explicit
Sub test()
Dim myA(20) As String
Dim myCt As Integer
Dim NrFiles As Integer
Call ReadAttachments(myA, Range("H1:H10"), False, NrFiles)
For myCt = 1 To NrFiles
Debug.Print myCt, myA(myCt)
Next myCt
End Sub
Sub ReadAttachments(ByRef myAttachments() As String, myRange As Range, _
hasHeader As Boolean, FileCt As Integer)
Dim myCell As Range
Dim iCt As Integer
For Each myCell In myRange
If iCt <> 0 Then
If myCell.Value <> "" Then
myAttachments(iCt) = myCell.Value
FileCt = FileCt + 1
End If
End If
iCt = iCt + 1
Next myCell
End Sub
The goal of this script is to loop through each criteria filtered in Column C, starting from C8 where my header is located. The information below will be a list of names of customer which will vary in quantity.
So far, the script filters each value. However, it does this literally. When I run the code step by step I need to press F8 three times to finish the loop of Client 1, and two times for Client 2.
How can I best improve the filtering? Ideally, the script should filter Client 1 then copy the range A8:M8 with dropdown and create an email (I have this other script ready); then it should filter client 2 and do the same.
Is there a way the filter can go through each criteria just once and then jump into the other?
Thanks in advance for the clarifications.
Sub Filtering()
Dim Clients As Variant, Name As Variant
Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
If Sheets("Hermes").AutoFilterMode = True Then
'Do Nothing
Else
ws.Range("A8:M8").AutoFilter Field:=3 'Filtering the column Ship To Names with the clients' names
With Range("C8", Range("C" & Rows.Count).End(xlUp))
Clients = .SpecialCells(xlVisible).Value
For Each Name In Clients
.AutoFilter Field:=3, Criteria1:=Name
'Place script to create email for this specific client.
Next Name
.AutoFilter
End With
End If
End Sub
Wizhi below provided the solution. I replaced my filtering script with his/hers and added the script that generates the emails, resulting in this one I am pasting below. NOTE: Amends need to be done as the script is not taking the correct email for each customer nor attaching all of the PDFs*
'Option Explicit
Sub Filtering()
Dim ws As Worksheet
Dim lrow_Critera_Data_Range As Long, lcol_Critera_Data_Range As Long
Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
If Sheets("Hermes").AutoFilterMode Then 'If autofilter exists, then remove filter
Sheets("Hermes").AutoFilterMode = False
End If
'##### Get all the uniqe filter values #####
ws.AutoFilterMode = False 'Remove filter
Dim Critera_Data_Range() 'Range to filter
Dim Unique_Criteria_Data As Object 'Range to filter but with only unique values
Dim Filter_Row As Long
Set Unique_Criteria_Data = CreateObject("Scripting.Dictionary") 'Create dictionary to store unique values
lrow_Critera_Data_Range = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row 'Last row in filter range
lcol_Critera_Data_Range = ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column 'Last column in filter range
Critera_Data_Range = Application.Transpose(ws.Range(ws.Cells(8, "C"), ws.Cells(lrow_Critera_Data_Range, "C"))) 'Get all the Client names
For Filter_Row = 2 To UBound(Critera_Data_Range, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
Unique_Criteria_Data(Critera_Data_Range(Filter_Row)) = 1 'Add value to dictionary
Next
'##### Loop through all the unqie Filter values and copy #####
Dim Filter_Value As Variant
Dim MyRangeFilter As Range
Set MyRangeFilter = ws.Range(ws.Cells(8, "A"), ws.Cells(lrow_Critera_Data_Range, lcol_Critera_Data_Range)) 'Set filter range
For Each Filter_Value In Unique_Criteria_Data.Keys 'Filter through all the unique names in dictionary "Unique_Criteria_Data"
'Debug.Print "Current Criteria: " & Filter_Value 'Print current unique Destination Pincode name
With MyRangeFilter
.AutoFilter Field:=3, Criteria1:=Filter_Value, Operator:=xlFilterValues 'Filtering the 3rd column and filter the current filter value
End With
ws.Range(ws.Cells(8, "A"), ws.Range(ws.Cells(8, "A"), ws.Cells(ws.Cells(Rows.Count, "C").End(xlUp).Row, ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column))).SpecialCells(xlCellTypeVisible).Copy 'copy only visible data from the filtering
Application.CutCopyMode = False 'Clear copy selection
'Paste script and then
'Place script to create email for this specific client.
' Make all the Dims
Dim OutApp As Object
Dim OutMail As Object
Dim SigString As String
Dim Signature As String
Dim rng As Range
Dim lRow As Long, lCol As Long
Dim StrBody As String
'Select the signature to use
SigString = Environ("appdata") & _
"\Microsoft\Signatures\" & Cells(2, 7).Text & ".htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
' Set the abbreviations
Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
StrBody = Sheets("Hermes").Range("C5").Value
filePath = ws.Cells(5, 1)
Subject = ws.Cells(2, 5)
i = 9
'Select the appropriate range to copy and paste into the body of the email
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Hermes").Range("A8:M" & Range("A8:M8").End(xlDown).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not valid." & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Create email
With OutMail
.Subject = Cells(i, 19).Text & "- " & Subject & Date
.To = Cells(i, 15).Value
.CC = Cells(i, 16).Value
.Bcc = Cells(i, 17).Value
.Importance = 2
.Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & Signature
.SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Next Filter_Value
On Error Resume Next
ws.ShowAllData 'Reset filter
On Error GoTo 0
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
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: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
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
So I made some adjustments to your code since I didn't understood the logic.
I.e. The check for autofilter is changed. I also defined the last row / last column to make it a bit more easy to follow the code.
So the logic for the filter is to take all the values in the range you want to filter and then get all the unique values from that range. Then you filter for each unique value in a for each loop (i.e. use that unique value as filter criteria).
I just made a .SpecialCells(xlCellTypeVisible).Copy with the header and the data since I don't know what you want to do after each filtering :).
Think this should be a quite easy start and might need to adjust part of the code to fit into your project (i.e. active filter or not etc..).
Full Code:
Option Explicit
Sub Filtering()
Dim ws As Worksheet
Dim lrow_Critera_Data_Range As Long, lcol_Critera_Data_Range As Long
Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
If Sheets("Hermes").AutoFilterMode Then 'If autofilter exists, then remove filter
Sheets("Hermes").AutoFilterMode = False
End If
'##### Get all the uniqe filter values #####
ws.AutoFilterMode = False 'Remove filter
Dim Critera_Data_Range() 'Range to filter
Dim Unique_Criteria_Data As Object 'Range to filter but with only unique values
Dim Filter_Row As Long
Set Unique_Criteria_Data = CreateObject("Scripting.Dictionary") 'Create dictionary to store unique values
lrow_Critera_Data_Range = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row 'Last row in filter range
lcol_Critera_Data_Range = ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column 'Last column in filter range
Critera_Data_Range = Application.Transpose(ws.Range(ws.Cells(8, "C"), ws.Cells(lrow_Critera_Data_Range, "C"))) 'Get all the Client names
For Filter_Row = 2 To UBound(Critera_Data_Range, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
Unique_Criteria_Data(Critera_Data_Range(Filter_Row)) = 1 'Add value to dictionary
Next
'##### Loop through all the unqie Filter values and copy #####
Dim Filter_Value As Variant
Dim MyRangeFilter As Range
Set MyRangeFilter = ws.Range(ws.Cells(8, "A"), ws.Cells(lrow_Critera_Data_Range, lcol_Critera_Data_Range)) 'Set filter range
For Each Filter_Value In Unique_Criteria_Data.Keys 'Filter through all the unique names in dictionary "Unique_Criteria_Data"
'Debug.Print "Current Criteria: " & Filter_Value 'Print current unique Destination Pincode name
With MyRangeFilter
.AutoFilter Field:=3, Criteria1:=Filter_Value, Operator:=xlFilterValues 'Filtering the 3rd column and filter the current filter value
End With
ws.Range(ws.Cells(8, "A"), ws.Range(ws.Cells(8, "A"), ws.Cells(ws.Cells(Rows.Count, "C").End(xlUp).Row, ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column))).SpecialCells(xlCellTypeVisible).Copy 'copy only visible data from the filtering
Application.CutCopyMode = False 'Clear copy selection
'Paste script and then
'Place script to create email for this specific client.
Next Filter_Value
On Error Resume Next
ws.ShowAllData 'Reset filter
On Error GoTo 0
End Sub
First off, I'm very new with VBA. Still learning so I may be making some obvious mistakes.
I'm trying to build emails using an Excel spreadsheet that I'm pulling information from to populate To, Subject, and Body of the emails. These are going to sales people to review information for their customers. I need each email to be based on the customer and sent to the corresponding sales reps. Some customers have multiple lines of information where as others have one and some sales people have overlapping customers.
The code I have found and have been trying to edit is (as far as I can tell) building the emails based on the email addresses. So I end up with an email that has a sales person in the To line and the body has all of the customers specifically for that sales person. Meanwhile the subject line is only pulling the one customer the email is meant to display.
Any help on this would be a godsend. I'm trying to reduce a 4-6 hour workload down to sub 1hr.
Any time I try to make changes to the code to base it on the customer rather than the email address I either end up breaking the code or not building an email and instead somehow just applying a filter to the spreadsheet that filters for the same information that was going into the email prior to the change.
I feel there may be more info necessary because I'm finding this to be far more complex than it appears but that may be me overthinking things. I've tried to limit this post to just the pertinent info but if I need to provide more I certainly will. I've been wracking my brain on this for weeks.
I have tried a variety of If And/Then statements to try and make the code look at the customer column rather than the email column but I can't find any combination that works. The code I posted below is what I have managed to get to work to some degree. Since I've tried so many variations I wouldn't know what would be the best mistake to include. So hopefully this is at least not too messy.
*Edit: The code requires a column of names in Column A which, as far as I understood, was supposed to be the condition that 'for this name create email using address in Column B.' But what it seems to be doing is creating an email using the address in Column B as the condition. So any customer line in A that matches the address in B gets thrown into the same email. I sort of need that to be the other way around. One email per customer of Column A to what ever email addresses are listed in Column B.
Edit2: Source info looking something like this:
+----------------+---------------------+---------+--------------+
| Customer | Email | Subj Ln | Email Body |
+----------------+---------------------+---------+--------------+
| Customer 1 | sales1#address.com | info | info |
| Customer 2 | sales2#address.com | info | info |
| Customer 2 | sales2#address.com | info | info |
| Customer 2 | sales2#address.com | info | info |
| Customer 3 | sales2#address.com | info | info |
| Customer 4 | sales3#address.com | info | info |
| Customer 4 | sales3#address.com | info | info |
| Customer 5 | sales1#address.com | info | info |
| Customer 6 | sales4#address.com | info | info |
+----------------+---------------------+---------+--------------+
So the code should be looking at the Customer Column (Column A) and looking for unique instances then generating an email with the appropriate email address in the Email Column (Column B). Each one should be a separate email and when the email addresses are unique to the customer it will do that. So, in the example above Customer 6 gets a singular email to sales4. The email generates the appropriate Subject Line and Email Body. However, Customer 1 will generate an email with the appropriate Subj Ln and Email Body (for Customer 1) and it will also have the appropriate sales1 email address. But since sales1 also has Customer 5, the Email Body information for Customer 5 is included in the Customer 1 email. When I need Customer 5 to be a separate email.
Edit3: I added the following paragraph as a comment below because I wasn't sure which would be the best way to get visibility to it.
I have been playing around with the code some more and think I may have found something that I didn't fully understand before. I'm not sure if I still do but I think I have a better understanding. -- It looks like the code is creating a filter that it uses to build the body of the email. It's filtering Column B (emails) for unique values and creating an email based on that. I think if I can change that filter code to filter for Column A and build an email using Column B, then I think I'll get what I'm looking for. I just can't figure out how to make that work.
I hope I'm clear. It is getting very confusing and overwhelming to me but I hope it is making sense. Also, I hope my formatting is correct.
Sub Send_Row_Or_Rows_2()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:AY" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in
column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*#?*.?*" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Cws.Cells(Rnum, 1).Value
.Subject = Ash.Cells(Rnum, 3) & " Bond Review " & Date
.HTMLBody = RangetoHTML(rng)
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
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: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
Public Function EOMonth(dInput As Date)
LastDayOfMonth = DateSerial(Year(dInput()), Month(dInput() + 1), -1)
End Function
I've written code like this quite a few times - the base template is actually on my github
The code:
Option Explicit
Sub LoopOverData()
Dim STbl As ListObject
Dim LastRow As Long
Dim WB As Workbook
Dim i As Long
Dim WS As Worksheet
Dim tblwsname As String
Set WB = ThisWorkbook
tblwsname = WB.Names("TblWSName").RefersToRange.Value2
Set WS = WB.Sheets(tblwsname)
Set STbl = WS.ListObjects("EmailDataTable")
LastRow = STbl.ListRows.Count
For i = 1 To LastRow
WB.Names("IterationNumber").RefersToRange.Value2 = i
Application.Calculate
Call CreateEmail
Next i
End Sub
Sub CreateEmail()
' This macro is for the pricing confirm e-mail
Dim outApp As New Outlook.Application
Dim OutMail As Object
Dim Attchmnt As String
Dim Signature As String
Dim WB As Workbook
Set WB = ThisWorkbook
Attchmnt = WB.Names("Attachment").RefersToRange.Value2
'We keep the file path for the attachment we're sending in Excel, for easy editing. Look in name manager to find it.
Application.EnableEvents = False
Application.ScreenUpdating = False
' We don't need the screen to flicker while the macro is running - it speeds things up.
Set OutMail = outApp.CreateItem(0)
'Signature = OutMail.Body
On Error Resume Next
With OutMail
.To = WB.Names("to").RefersToRange.Value2
.CC = WB.Names("cc").RefersToRange.Value2
.BCC = WB.Names("bcc").RefersToRange.Value2
.Subject = WB.Names("Subject").RefersToRange.Value2
.Body = WB.Names("Body").RefersToRange.Value2
.display
End With
If Attchmnt = "" Then
Else
OutMail.Attachments.Add Attchmnt
End If
'OutMail.send
'Remove this comment to directly send. Not recommended.
On Error GoTo 0
End Sub
The setup: You create a "sample email" basically, and you use =index(Range, IndexNum) to determine what item you're currently working on. IndexNum is a named range back to the base index, which the code will be changing.
Hence, as each number in the index gets moved, all of the formulas update to the new email that needs to be written. It then calls the email generating procedure, and creates (but doesn't send) the email needed. This is to give you a chance to review the emails before sending them.
You'll want the Microsoft Outlook 16.0 Object library enabled.
There might be some rule to sending the information that I'm missing - if that's the case, I recommend a few formulas or power query to do the compression
Try this, actually it generate needed number of emails. If OK, I'll clear the code
Option Explicit
Sub Send_Row_Or_Rows_2()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:BY" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in Column A
'FieldNum = 2
Columns("A:B").Select
Selection.Copy
ActiveSheet.Paste
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
ActiveSheet.Paste
' FilterRange.Columns(FieldNum).AdvancedFilter _
' Action:=xlFilterCopy, _
' CopyToRange:=Cws.Range("A:B"), _
' CriteriaRange:="", Unique:=True
Columns("A:B").Select
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$B$10").RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlYes
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=1, _
Criteria1:=Cws.Cells(Rnum, 1).Value
FilterRange.AutoFilter Field:=2, _
Criteria1:=Cws.Cells(Rnum, 2).Value
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 2).Value Like "?*#?*.?*" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
Debug.Print "to: " & .to & " subj: " & .Subject & " body:" & .htmlbody
.to = Cws.Cells(Rnum, 2).Value
.Subject = Ash.Cells(Rnum, 3) & " Bond Review " & Date
.htmlbody = RangetoHTML(rng)
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
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: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
Public Function EOMonth(dInput As Date)
LastDayOfMonth = DateSerial(Year(dInput()), Month(dInput() + 1), -1)
End Function
I using like that, First you need to convert your text to table and name it CustomersTbl or use
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' get last row
Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 4))
instead of
Set rng = ws.Range("CustomersTbl")
Here is a code
Sub Send_Row_Or_Rows_2()
' reference Microsoft Scripting Runtime
Dim OutApp As Object, OutMail As Object, dict As Object
Dim tKey(0 To 3, 0 To 1) As Variant
Dim rng As Range
Dim ws As Worksheet
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False ' speedup Application, disable events
.ScreenUpdating = False ' prevent flashing, disable screen
End With
Set ws = ThisWorkbook.Worksheets("Sheet1") ' set shortest variable for worksheet
Set dict = CreateObject("Scripting.Dictionary") ' set object for unique values
Set rng = ws.Range("CustomersTbl") ' get range to variable
'LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' get last row
'Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 4)) 'get range to variable
For Each cRow In rng ' create unique dictionary
i = i + 1 ' increment
strCustomer = rng(i, 1)
strEmail = rng(i, 2)
strSubj = rng(i, 3)
strBody = rng(i, 4)
If dict.Exists(strCustomer) Then ' if dublicate
Dim tempArr() As Variant
tempArr() = dict(strCustomer)
If UBound(tempArr, 2) > 0 Then ' if not nothing
If Not IsEmpty(tempArr(0, 1)) Then ' if second element empty
sCount = UBound(tempArr, 2) + 1
Else
sCount = UBound(tempArr, 2) ' as is empty array
End If
End If
ReDim Preserve tempArr(0 To 3, 0 To sCount) ' redim array to next array size
tempArr(0, sCount) = strCustomer 'fill array element
tempArr(1, sCount) = strEmail 'fill array element
tempArr(2, sCount) = strSubj 'fill array element
tempArr(3, sCount) = strBody 'fill array element
dict(strCustomer) = tempArr ' put array to dictionary by unique name
Else
tKey(0, 0) = strCustomer 'fill array element
tKey(1, 0) = strEmail 'fill array element
tKey(2, 0) = strSubj 'fill array element
tKey(3, 0) = strBody 'fill array element
dict.Add strCustomer, tKey ' create unique name
End If
Next cRow ' loop next row
' now dict contains only unique elements, lets loop throught them
For Each UniqueCustomer In dict ' for each unique element
countEmails = UBound(dict(UniqueCustomer), 2) ' count emails of unique group
For i = 0 To countEmails ' loop each email in group
strCustomer = dict(UniqueCustomer)(0, i)
strEmail = dict(UniqueCustomer)(1, i)
strSubj = dict(UniqueCustomer)(2, i)
strBody = dict(UniqueCustomer)(3, i)
If Not IsEmpty(strCustomer) Then ' if element not empty create email
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = strEmail
.Subject = strSubj
.HTMLBody = strBody
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
Else
GoTo sNext
End If
Stop
sNext:
Next I ' next email
Next UniqueCustomer 'next unique
cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
If I understand correctly, you want send emails based upon a unique combination of Customer and Email Address, and for each unique combo get the corresponding subject line and email body. So in your example above, I am assuming that since customer2 and Customer4 are duplicates, then you only want to send one email for each customer and use the corresponding subject line and email body found at the first occurrence of the Cutomer2 or 4.
If my assumptions are correct, then the code below should do the job. Note the comments that explain each step.
Edit: I forgot to mention that using delimiter as I did originally is risky, because that delimiter could exist somewhere in the data and splitting by that delimiter would throw off your results. So, the better method, (and I believe more clean as well), would be the following:
Option Explicit
Public Sub SendEmails()
Dim objDict As Object
Dim objWB As Workbook
Dim objWS As Worksheet
Dim rngToLookUp As Range
Dim lngLastRow As Long, i As Long
Dim arryEmailData As Variant
Dim objOutlookApp As Object, objOutlookEmail As Object
Dim varKey As Variant, arryTemp As Variant
Application.ScreenUpdating = False
Set objWB = Workbooks("SomeWBName")
Set objWS = objWB.Worksheets("SomeWSName")
lngLastRow = objWS.Cells(objWS.Rows.Count, "A").End(xlUp).Row 'Find last row with data
Set rngToLookUp = objWS.Range("A2:D" & lngLastRow) 'set range for last row of data
arryEmailData = rngToLookUp.Value2 'Get the email data from the sheet into an array
Set objDict = CreateObject("Scripting.Dictionary") 'set the dicitonary object
Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object
For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
varKey = Join(Array(arryEmailData(i, 1), arryEmailData(i, 2)), "|") 'Concatenate columns A and B using '|' as a
'delimiter to form a unique Key
If Not objDict.Exists(varKey) Then
objDict(varKey) = Array(arryEmailData(i, 2), _
arryEmailData(i, 3), _
arryEmailData(i, 4))
End If
varKey = Empty
Next i
'for each unique key in the dicitonary
'get the corresponding item which is an array
'created in the loop above
On Error GoTo cleanup
For Each varKey In objDict.Keys
arryTemp = objDict.Item(varKey)
Set objOutlookEmail = objOutlookApp.CreateItem(0)
With objOutlookEmail
.To = arryTemp(0)
.Subject = arryTemp(1)
.Body = arryTemp(2)
.Send
End With
Set objOutlookEmail = Nothing
arryTemp = Empty
Next
MsgBox "All Emails have been sent", vbInformation
cleanup:
Set objOutlookApp = Nothing
Application.ScreenUpdating = True
End Sub
Original Post:
Option Explicit
Public Sub SendEmails()
Dim objDict As Object
Dim objWB As Workbook
Dim objWS As Worksheet
Dim rngToLookUp As Range
Dim lngLastRow As Long, i As Long
Dim arryEmailData As Variant
Dim objOutlookApp As Object, objOutlookEmail As Object
Dim varKey As Variant, arryTemp As Variant
Application.ScreenUpdating = False
Set objWB = Workbooks("SomeWBName")
Set objWS = objWB.Worksheets("SomeWSName")
lngLastRow = objWS.Cells(objWS.Rows.Count, "A").End(xlUp).Row 'Find last row with data
Set rngToLookUp = objWS.Range("A2:D" & lngLastRow) 'set range for last row of data
arryEmailData = rngToLookUp.Value2 'Get the email data from the sheet into an array
Set objDict = CreateObject("Scripting.Dictionary") 'set the dicitonary object
Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object
For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
varKey = Join(Array(arryEmailData(i, 1), arryEmailData(i, 2)), "|") 'Concatenate columns A and B using '|' as a
'delimiter to form a unique Key
If Not objDict.Exists(varKey) Then 'If the key doesn't already exist, then concatenate
'the corresponding Email Address, subject line,
'and email body using
''|' as a delimiter
objDict(varKey) = Join(Array(arryEmailData(i, 2), _
arryEmailData(i, 3), _
arryEmailData(i, 4)), "|")
End If
varKey = Empty
Next i
'for each unique key in the dicitonary
'get the corresponding item
'split the item into a 3 element array using '|' delimiter that
'was originally used to concatenate the item in the loop above
On Error GoTo cleanup
For Each varKey In objDict.Keys
arryTemp = Split(objDict.Item, "|")
Set objOutlookEmail = objOutlookApp.CreateItem(0)
With objOutlookEmail
.To = arryTemp(0)
.Subject = arryTemp(1)
.Body = arryTemp(2)
.Send
End With
Set objOutlookEmail = Nothing
Next
MsgBox "All Emails have been sent", vbInformation
cleanup:
Set objOutlookApp = Nothing
Application.ScreenUpdating = True
End Sub
I am trying to automate the email process which we have been sending to various stack holders.
I wanted to filter the column D based on company code and send out the email to the people listed in O column ( the email should not be duplicated), and also need to include CC (without duplicates)
Below is the VBA which am trying, but could not include the TO and CC.
Sub Send_Row_Or_Rows_2()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim StrBody As String
Dim StrBody2 As String
Dim FileToAttach As String
Dim RngTo As Range
Set RngTo = Ash.Columns("H").Offset(1, 0).SpecialCells(xlCellTypeVisible)
StrBody = "<BODY style=font-size:11pt;font-family:Calibri>Dear Approver,<p>Please be informed that below invoices are waiting for your approval in BasWare for more than 10 days. Please check them and take action accordingly as soon as possible.</BODY>"
'On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = Worksheets("rawdata")
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A4:M" & Ash.Rows.Count)
FieldNum = 4 'Filter column = D because the filter range start in column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*?*?*" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Ash.Cells(Rnum, 15).Value
.SentOnBehalfOfName = "CDM_Basware_Administration#esab.com"
.CC = sCC
.Subject = "Reminder - Pending Invoices - More than 10 days"
.HTMLBody = StrBody & RangetoHTML(rng) & signature
FileToAttach = "C:\Users\gyousz\Desktop\Weekly_Customer CL3 and PT Control file_May_2018"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
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 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
Please divide your codes into separate functions:
One for getting recipients
One to send email
I have recreated your workbook. Code below would do the ff:
Get all company codes first
Filter list by company codes
Get TO and CC list
Send email
Only modification left here is creating another function for sending email (and pass the variables).
Sub Send_Row_Or_Rows_2()
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo ErrorHandler
' Initialization
' ==================================================
Dim shtRec As Worksheet: Set shtRec = ThisWorkbook.Sheets("rawdata")
Dim intLastRow As Long, intLastCol As Long ' for end cell
Dim i As Long, j As Long, k As Long, rngCell As Range ' for loops
Dim rngFilter As Range ' filter range
Dim strEmailTO As String, strEmailCC As String ' recipients
Dim arrCoCd() As String ' company codes
Dim arrEmailTO() As String ' TO recipients
Dim arrEmailCC() As String ' CC recipients
Dim arrEmailRec() As String, strEmailRec As String ' temporary variables
' Get Recipient header column indexes
Dim intRowHead As Integer: intRowHead = 4 ' header row
Dim intColCoCd As Integer: intColCoCd = 1 ' company code column
Dim intColTo As Integer: intColTo = 3 ' TO column
Dim intColCc As Integer: intColCc = 4 ' CC column
' Filter Recipients by Company Code
' ==================================================
With shtRec
' Remove filter
If Not .AutoFilter Is Nothing Then .AutoFilterMode = False
' Get end cell
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
' Add filter
Set rngFilter = .Range(Cells(intRowHead, 1), Cells(intLastRow, intLastCol))
rngFilter.AutoFilter
' Get list of company codes
' =========================
ReDim arrCoCd(1 To intLastRow)
For i = (intRowHead + 1) To intLastRow ' exclude header
With .Cells(i, intColCoCd)
If .Value <> vbNullString Then
k = k + 1
arrCoCd(k) = VBA.Trim(.Value)
End If
End With
Next i
' Reset variable
k = 0
' Get unique values
' =========================
arrCoCd = FnStrUniqueArray(arrCoCd)
' Filter by Company Code
For i = LBound(arrCoCd) To UBound(arrCoCd)
If arrCoCd(i) <> vbNullString Then
rngFilter.AutoFilter Field:=intColCoCd, Criteria1:="=" & arrCoCd(i)
While Not Application.CalculationState = xlDone: DoEvents: Wend
' Get list only if with results
If .AutoFilter.Range.Columns(intColCoCd).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
Dim strRng As String
' Get TO list
' =========================
' Loop each visible cell in TO column
k = 0
strRng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Columns(intColTo).Address(False, False)
For Each rngCell In .Range(strRng)
' Remove spaces
strEmailRec = VBA.Trim(VBA.Replace(rngCell.Value, " ", ""))
' Get email addresses
arrEmailRec = VBA.Split(strEmailRec, ";")
' Add email addresses to list
If k = 0 Then k = k + 1 Else k = UBound(arrEmailTO) + 1
ReDim Preserve arrEmailTO(1 To k)
For j = LBound(arrEmailRec) To UBound(arrEmailRec)
arrEmailTO(k) = arrEmailRec(j)
Next j
' Remove duplicates in list
arrEmailTO = FnStrUniqueArray(arrEmailTO)
' Reset variables
strEmailRec = vbNullString
Erase arrEmailRec
Next rngCell
' Get CC list
' =========================
' Loop each visible cell in CC column
k = 0
strRng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Columns(intColCc).Address(False, False)
For Each rngCell In .Range(strRng)
' Remove spaces
strEmailRec = VBA.Trim(VBA.Replace(rngCell.Value, " ", ""))
' Get email addresses
arrEmailRec = VBA.Split(strEmailRec, ";")
' Add email addresses to list
If k = 0 Then k = k + 1 Else k = UBound(arrEmailCC) + 1
ReDim Preserve arrEmailCC(1 To k)
For j = LBound(arrEmailRec) To UBound(arrEmailRec)
arrEmailCC(k) = arrEmailRec(j)
Next j
' Remove duplicates in list
arrEmailCC = FnStrUniqueArray(arrEmailCC)
' Reset variables
strEmailRec = vbNullString
Erase arrEmailRec
Next rngCell
End If
' Join recipients list
strEmailTO = VBA.Join(arrEmailTO, ";")
strEmailCC = VBA.Join(arrEmailCC, ";")
' Send email
Set OutMail = OutApp.CreateItem(0)
Dim strSubject As String: strSubject = "Reminder - Pending Invoices - More than 10 days"
Dim strAttachment As String: strAttachment = "C:\Users\gyousz\Desktop\Weekly_Customer CL3 and PT Control file_May_2018"
Dim strSendOnBehalf As String: strSendOnBehalf = "CDM_Basware_Administration#esab.com"
On Error Resume Next
With OutMail
.To = strEmailTO
.SentOnBehalfOfName = strSendOnBehalf
.CC = strEmailCC
.Subject = strSubject
.HTMLBody = StrBody & RangetoHTML(rng) & signature
.Attachments.Add strAttachment
.Display
End With
On Error GoTo 0
' Reset variables
Erase arrEmailTO
Erase arrEmailCC
End If
Next i
End With
ErrorHandler:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Here is the code to remove duplicates in arrays.
Reference:vba get unique values from array
Function FnStrUniqueArray(aTmpArray() As String)
Dim ctr As Long, cTmpCollection As New Collection, cTmpCollect
For Each cTmpCollect In aTmpArray
cTmpCollection.Add cTmpCollect, cTmpCollect
Next
' convert collection to array
ReDim aTmpArray(1 To cTmpCollection.Count)
For ctr = 1 To cTmpCollection.Count
aTmpArray(ctr) = cTmpCollection(ctr)
Next ctr
Set cTmpCollection = Nothing
FnStrUniqueArray = aTmpArray
End Function
I guess I would like to know what your results look like now but you could do the following -- you would need to sort your sheet by Company
DIM TheToList, TheCCList, CurrRow
CurrRow = 1
Do until --end of the sheet is reached ---
TheToList = ""
TheCCList = ""
if cells(CurrRow, 4) = cells(CurrRow-1,4) then ' same company
' I was wrong >>> if instr(1,TheCCList,cells(CurrRow,15)) = 0 then ' diff TO
if instr(1,TheToList,cells(CurrRow,15)) = 0 then ' diff TO
TheToList = TheToList & cells(CurrRow,15) & "; "
end if
if instr(1,TheCCList,cells(CurrRow,16)) = 0 then ' diff CC
TheCCList = TheCCList & cells(CurrRow,16) & "; "
end if
else
if CurrRow <> 1 then
' do your output here because the company has changed
' probably call a subroutine because you will need it at the end too
end if
TheToList = ""
TheCCList = ""
end if
CurrRow = CurrRow + 1
Loop
' call your output subroutine one more time
I will address the problem of creating unique emailTO and emailCC from Cws sheet.
For this i suggest you use dictionaries.
Add a reference to 'Microsoft Scripting Runtime' as per screenshot.
Also given an improvement and suggestion on how to attach the file.
Sub Send_Row_Or_Rows_2()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim StrBody As String
Dim StrBody2 As String
Dim FileToAttach As String
Dim RngTo As Range
Set RngTo = Ash.Columns("H").Offset(1, 0).SpecialCells(xlCellTypeVisible)
StrBody = "<BODY style=font-size:11pt;font-family:Calibri>Dear Approver,<p>Please be informed that below invoices are waiting for your approval in BasWare for more than 10 days. Please check them and take action accordingly as soon as possible.</BODY>"
'On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = Worksheets("rawdata")
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A4:M" & Ash.Rows.Count)
FieldNum = 4 'Filter column = D because the filter range start in column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
'find unique emails for TO as CC
Dim dictTO As New Dictionary
Dim dictCC As New Dictionary
Dim emailTO As String
Dim emailCC As String
For Rnum = 2 To Rcount
emailTO = Trim(UCase(Cws.Range("O" & Rnum).Value))
emailCC = Trim(UCase(Cws.Range("P" & Rnum).Value))
If Not (emailTO = "") Then
If Not dictTO.Exists(emailTO) Then
Call dictTO.Add(emailTO, emailTO)
End If
End If
If Not (emailCC = "") Then
If Not dictCC.Exists(emailCC) Then
Call dictCC.Add(emailCC, emailCC)
End If
End If
Next Rnum
'remove CC emails that are in To dict
For Rnum = 1 To dictTO.Count
If dictCC.Exists(dictTO.Item(Rnum)) Then
dictCC.Remove (dictTO.Item(Rnum))
End If
Next
emailTO = ""
emailCC = ""
'Generate To Addresses
For Rnum = 1 To dictTO.Count
emailTO = emailTO & dictTO.Item(Rnum) & ","
Next
'Generate CC Addresses
For Rnum = 1 To dictTO.Count
emailCC = emailCC & dictCC.Item(Rnum) & ","
Next
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
FileToAttach = "C:\Users\gyousz\Desktop\Weekly_Customer CL3 and PT Control file_May_2018"
'fixed file being attached everytime - maybe saved a copy of Cws sheet and attach the workbook
On Error Resume Next
Dim fso As New FileSystemObject
With OutMail
.To = emailTO
.SentOnBehalfOfName = "CDM_Basware_Administration#esab.com"
.CC = emailCC
.Subject = "Reminder - Pending Invoices - More than 10 days"
.HTMLBody = StrBody & RangetoHTML(rng) & Signature
If (fso.FileExists(File)) Then 'checking if file exists
.Attachments.Add FileToAttach 'corrected how to add an attachment
End If
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
'Close AutoFilter
Ash.AutoFilterMode = False
End If
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
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 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
Good luck
try manipulating this;
Sub sendmail10101()
Dim obApp As Object
Dim NewMail As MailItem
Set obApp = Outlook.Application
Set NewMail = obApp.CreateItem(olMailItem)
'You can change the concrete info as per your needs
With NewMail
.Subject = Cells(21, 3).Value
.To = Cells(18, 3).Value
.Body = "Good day" & vbCrLf & "i hope you are keeping well " & vbCrLf & vbCrLf & "please can you assist with the below members infomation;" & vbCrLf & vbCrLf & vbCrLf & Cells(20, 3).Value
'.Attachments.Add ("C:\Attachments\Test File.docx") IF YOU WANT TO ADD AN ATTACHMENT
.Importance = olImportanceHigh
.Display 'YOU CAN CHANGE TO SEND WHEN READY TO AUTOMATE
End With
Set obApp = Nothing
Set NewMail = Nothing
End Sub
instead of duplicating run the for loop;
for i = 1 to 20 at start of code
cells(i,1) where the data to be looped
next i before end sub
and you can use a filer add on at the beginning of the code to filter before starting the loop (obviously make sure that you set a filter on the data before using this type of code);
Sub AutoFilter_Text_Examples()
'Examples for filtering columns with TEXT
Dim lo As ListObject
Dim iCol As Long
'Set reference to the first Table on the sheet
Set lo = Sheet1.ListObjects(1)
'Set filter field
iCol = lo.ListColumns("Product").Index
'Clear Filters
lo.AutoFilter.ShowAllData
'All lines starting with .AutoFilter are a continuation
'of the with statement.
With lo.Range
'Single Item
.AutoFilter Field:=iCol, Criteria1:="Product 2"
'2 Criteria using Operator:=xlOr
.AutoFilter Field:=iCol, _
Criteria1:="Product 3", _
Operator:=xlOr, _
Criteria2:="Product 4"
'More than 2 Criteria (list of items in an Array function)
.AutoFilter Field:=iCol, _
Criteria1:=Array("Product 4", "Product 5", "Product 7"), _
Operator:=xlFilterValues
'Begins With - use asterisk as wildcard character at end of string
.AutoFilter Field:=iCol, Criteria1:="Product*"
'Ends With - use asterisk as wildcard character at beginning
'of string
.AutoFilter Field:=iCol, Criteria1:="*2"
'Contains - wrap search text in asterisks
.AutoFilter Field:=iCol, Criteria1:="*uct*"
'Does not contain text
'Start with Not operator <> and wrap search text in asterisks
.AutoFilter Field:=iCol, Criteria1:="<>*8*"
'Contains a wildcard character * or ?
'Use a tilde ~ before the character to search for values with
'wildcards
.AutoFilter Field:=iCol, Criteria1:="Product 1~*"
End With
End Sub
and to clear filter;
Sub Clear_All_Table_Filters_On_Sheet()
Dim lo As ListObject
'Loop through all Tables on the sheet
For Each lo In Sheet1.ListObjects
'Clear All Filters for entire Table
lo.AutoFilter.ShowAllData
Next lo
End Sub
so you can use a message box which sets the filter and then triggers the automated mail depending on what you require and the filter gets undone and resets for next use.
Hi I got a code which would filter the unique values in the A column and copy the whole range from A1:H, but I want to ignore the first column and want range to be copied form B1:H.
Eg: if there is a table with marks of students and I want to post the individual marks table to every student separately. This macro is sending the table along with the student name which is in the first column, but I need only marks table, don't need students name along with that.
Here is my code
Sub Send_Row_Or_Rows_1()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim StrBody As String
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Ash = ActiveSheet
'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0
If mailAddress <> "" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = mailAddress
.Subject = "Test mail"
.HTMLBody = StrBody & RangetoHTML(rng)
.Display 'Or use Send
StrBody = Sheets("Body").Range("A1").Value & "<br>" & _
Sheets("Body").Range("A2").Value & "<br>" & _
Sheets("Body").Range("A3").Value & "<br><br><br>"
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
If you want to stick with your solution rather than using Word's Mailing tools,
Just change this line :
Set rng = .SpecialCells(xlCellTypeVisible)
To
Set rng = Application.Intersect(.SpecialCells(xlCellTypeVisible),Ash.Range("B:H"))
By using offset you can select specific filtered column without heading or with heading
Please have a look below code :
Set rng = .AutoFilter.Range.Offset(1, ColumnNumber).Resize(.AutoFilter.Range.Rows.Count - 1, ColumnCount).SpecialCells(xlCellTypeVisible)
ColumnNumber - start column to copy
ColumnCount - number of columns to copy
Try below one :
set rng = Ash.Autofilter.Range.Offset(1).Resize(Ash.AutoFilter.Range.Rows.Count - 1,7).SpecialCells(xlCellTypeVisible)