我正在尝试自动化我们发送给各个堆栈持有者的电子邮件流程。
我想根据公司代码过滤D列并将电子邮件发送给O列中列出的人员(电子邮件不应重复),并且还需要包含抄送(不重复)
下面是正在尝试的VBA,但无法包含TO和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
最佳答案
请将您的代码划分为单独的函数:
- 用于获取收件人
- 一个用于发送电子邮件
我重新创建了您的工作簿。下面的代码将执行 ff:
- 首先获取所有公司代码
- 按公司代码过滤列表
- 获取收件人和抄送列表
- 发送电子邮件
这里剩下的唯一修改是创建另一个用于发送电子邮件的函数(并传递变量)。
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
这是删除数组中重复项的代码。 引用: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
关于excel - VBA过滤和发送电子邮件,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/52697301/