Question

我正在尝试自动化我们一直发送给各个堆栈持有人的电子邮件流程。

我想根据公司代码过滤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

Answer 1

我想我想知道您现在的结果如何，但是您可以执行以下操作-您需要按公司对工作表进行排序

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

Answer 2

我将解决从Cws工作表创建唯一的emailTO和emailCC的问题。为此，我建议您使用字典。

根据屏幕快照添加对“ Microsoft脚本运行时”的引用。

还对如何附加文件提出了改进和建议。

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

祝你好运

Answer 3

请将您的代码分为单独的功能：

一个用于获取收件人的
一个发送电子邮件的人

我重新创建了您的工作簿。下面的代码可以执行以下操作：

首先获取所有公司代码
按公司代码过滤列表
获取“收件人”和“抄送”列表
发送电子邮件

仅剩下的修改就是创建另一个发送电子邮件（并传递变量）的功能。

    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
                    ' <your code to send email passing variables - strEmailTO, strEmailCC, ...>

                    ' 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

Answer 4

尝试操作；

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

而不是重复运行for循环；

对于i = 1至20的代码开头

要循环处理数据的单元格（i，1）

在结束子之前下一个i

并且您可以在开始循环之前使用文件管理器添加在代码的开头进行过滤（显然，请确保在使用这种类型的代码之前对数据设置过滤器）；

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

并清除过滤器；

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

因此您可以使用一个消息框，该消息框会设置过滤器，然后根据您的要求触发自动邮件，并且过滤器将撤消并重置以供下次使用。

VBA筛选和发送电子邮件

4 个答案: