可以将文章内容翻译成中文,广告屏蔽插件可能会导致该功能失效(如失效，请关闭广告屏蔽插件后再试):
问题:
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
回答1:
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
回答2:
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
回答3:
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
回答4:
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.
{var%20f='http://v.t.sina.com.cn/share/share.php?appkey=1515056452',u=z||d.location,p=['&url=',e(u),'&title=',e(t||d.title),'&source=',e(r),'&sourceUrl=',e(l),'&content=',c||'gb2312','&pic=',e(p||'')].join('');function%20a(){if(!window.open([f,p].join(''),'mb',['toolbar=0,status=0,resizable=1,width=440,height=430,left=',(s.width-440)/2,',top=',(s.height-430)/2].join('')))u.href=[f,p].join('');};if(/Firefox/.test(navigator.userAgent))setTimeout(a,0);else%20a();})(screen,document,encodeURIComponent,'','','https://i.stack.imgur.com/xHk9T.jpg', '推荐 再贱就再见 的文章《VBA to filter and send email》','https://www.manongdao.com/article-2186080.html','页面编码gb2312|utf-8默认gb2312'));){kind=link}