VBA过滤和发送电子邮件
Kel*_*vin 5 excel vba excel-vba email-attachments outlook-vba
我正在尝试自动化我们发送给各种堆栈持有者的电子邮件过程.
我想根据公司代码过滤D列,并将电子邮件发送给O列中列出的人员(电子邮件不应重复),还需要包含CC(不重复)
以下是我正在尝试的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
我想我想知道您的结果现在是什么样子，但您可以执行以下操作 - 您需要按公司对工作表进行排序
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