从Excel Loop创建电子邮件 [英] Create Emails from Excel Loop

问题描述

我有这个样本表:

I have this sample sheet:

我的代码目前正在处理中，并根据H列中的名称创建电子邮件.因此Approver1为其所有人收到一封电子邮件.我得到了删除重复的员工姓名的信息.示例:批准者1收到一封电子邮件，上面写着请为下面的所有雇员批准时间:"，然后列出名称... Sample1，Sample2和Sample3.工作表通常会为每个批准人配备受骗员工，如我上面的工作表所示.

My code currently goes through and creates emails based on the name in column H. So Approver1 gets one email for all his people. I have gotten it to de-dupe any repeats of their employee names. Example: Approver 1 gets an email that says 'please approve time for all of your employees below:' and then there is a list of names...Sample1, Sample2, and Sample3. The sheet will often have dupe employees for each approver, as shown in my sheet above.

该代码适用于第一组重复名称(连续最多可以有10个相同的批准人，都收到一封电子邮件)，然后在任何一个中都能正常运行.

The code works well for the first set of dupe names (there could be up to 10 of the same Approvers in a row, all getting one email), then runs fine through any singles.

当到达下一组重复的批准者时，它将跳过该组中的第一行，然后为每个 other 部门创建电子邮件；因此它会跳过一行，直到到达dupe批准者部分的末尾.因此，从工作表中，approver1会设置他的电子邮件，然后approver2会收到她的电子邮件，但是approver3会变得一团糟.

When it hits the next set of repeated approvers it skips the first row in that group, then creates emails for every other division; so it skips a row until it gets to the end of the dupe approver section. So from the sheet, approver1 would get his email all set, then approver2 would get hers, but then approver3 becomes a mess.

我如何才能使其在整个列表中正确循环，为每个批准者创建一封电子邮件，而其人员的所有相应名称仅列出一次?

How do I get this to loop correctly through an entire list, creating one email for each approver, with all the corresponding names of their people listed only once?

Sub DivisionApprovals()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell, lookrng As Range
    Dim strdir As String
    Dim strFilename As String
    Dim sigString As String
    Dim strBody As String
    Dim strName As Variant
    Dim strName1 As Variant
    Dim strDept As Variant
    Dim strName2 As String
    Dim strbody2 As String
    Dim strName3 As Variant

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    Set rng = ActiveSheet.UsedRange

    r = 2

    Do While r <= rng.rows.count
        Set OutMail = OutApp.CreateItem(0)

        Set strName = rng.Cells(r, 1)
        Set strName3 = rng.Cells(r, 3)
        strName2 = Trim(Split(strName, ",")(1))

        strBody = "<Font Face=calibri>Dear " & strName2 & ", <br><br> Please approve the following divisions:<br><br>"

        With OutMail
            .To = rng.Cells(r, 2).Value
            .Subject = "Please Approve Divisions"
            List = strName3 & "<br>"


            Do While rng.Cells(r, 1).Value = rng.Cells(r + 1, 1)
                r = r + 1
                Set strDept = rng.Cells(r, 3)
                .Subject = "Approvals Needed!"
                List = .HTMLBody & strDept & "<br>"
                r = r + 1
                .HTMLBody = List
            Loop
            .HTMLBody = strBody & "<B>" & List & "</B>" & "<br>" & Signature
            .Display

        End With

        Set OutMail = Nothing
        r = r + 1
    Loop
    Set OutApp = Nothing
End Sub

推荐答案

我删除了之前的答案，然后在需要该信息的情况下将其删除.为了不混淆任何人，以下是根据OP的代码构建的答案.

I deleted the previous answer, then un-deleted it in case you need that info. So as to not confuse anyone, the answer building from the OP's code is below.

免责声明:我不喜欢Do While的增量代码样式，这使追赶错误非常困难，但我理解其意图.我在这里以自己的大脑运作方式以及更好的编码风格包括了以下代码，您可以自己判断.

DISCLAIMER: I am not a fan of the incrementing code style in the Do While, it make sit very difficult to chase errors but I understand the intention. I have included code below this in the way that my brain works and perhaps better coding style, you be the judge.

好吧@learningthisstuff我知道发生了什么，代码假定名称已排序.没有提供的一件事是，如果部门名称是相同的，它将被多次列出；如果部门代码不同，那么部门对于一个人是否总是唯一的(没有重复?).

Alright @learningthisstuff I figured out what was going on, the code assumes the names are sorted. One thing not provided for is if the dept names are the same it will be listed multiple times, are the dept always unique for a person (no dupes?) if there are dupes that is different code.

此代码有效，我只是将其作为宏在虚拟集上运行.重要的是排序和递增逻辑，在此过程中，我进行了一些更改，以使其更易于阅读/理解.

This code works I just ran it as a macro on a dummy set. Big thing was the sort AND the incrementing logic, I changed a few things to make it more readable/understandable along the way.

希望这对您有所帮助，并且您可以根据情况的变化进行修改.

I hope this helps you and you can modify as things change for you.

Sub Email_Macro()
'
' Email_Macro Macro
'
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell, lookrng As Range
    Dim strdir As String
    Dim strFilename As String
    Dim sigString As String
    Dim strBody As String
    Dim strName As Variant
    Dim strName1 As Variant
    Dim strDept As Variant
    Dim strName2 As String
    Dim strbody2 As String
    Dim strName3 As Variant
    Dim emailWS As Worksheet
    Dim nameCol As Double
    Dim deptCol As Double
    Dim lastRow As Double
    Dim startRow As Double
    Dim r As Double

    Dim depList As String
    deptList = ""


    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")


    Set emailWS = ThisWorkbook.ActiveSheet
    startRow = 2 ' starting row
    nameCol = 1 'col of name
    deptCol = 3 'col of dept

    'find the last row with a name in it from the name column
    lastRow = emailWS.Cells(emailWS.Rows.Count, nameCol).End(xlUp).Row

    'set variable to the starting row #
    r = startRow 'this is where the counting begins

    'sort the data first before going through the email process
    'assumes these are the only columns 1 (nameCol) thru 3 (deptCol) to sort
    'assumes you are sorting based on col 1 (nameCol)
    emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, deptCol)).Sort key1:=emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, nameCol))

    Do While r <= lastRow
        Set OutMail = OutApp.CreateItem(0)

        Set strName = emailWS.Cells(r, nameCol)
        Set strName3 = emailWS.Cells(r, deptCol)
        'careful the line below assumes there is always a comma separator in the name
        strName2 = Trim(Split(strName, ",")(1))

        strBody = "<Font Face=calibri>Dear " & strName2 & ", <br><br> Please approve the following divisions:<br><br>"

        With OutMail
            .To = emailWS.Cells(r, 2).Value
            .Subject = "Please Approve Divisions"
            deptList = strName3 & "<br>"


            Do While emailWS.Cells(r, 1).Value = emailWS.Cells(r + 1, 1)
                r = r + 1
                Set strDept = emailWS.Cells(r, 3)
                .Subject = "Approvals Needed!"
                deptList = deptList & strDept & "<br>"
            Loop
            .HTMLBody = strBody & "<B>" & deptList & "</B>" & "<br>" & Signature
            .Display

        End With

        Set OutMail = Nothing

        'conditionally increment the row based on the name difference
        If emailWS.Cells(r, 1).Value <> emailWS.Cells(r + 1, 1) Then
            r = r + 1 'increment if there is a new name or no name
            deptList = "" 'reset the department list
        Else 'Do nothing
        End If
    Loop
    Set OutApp = Nothing


End Sub

屏幕截图:

要证明我不会在没有解决方案/指导的情况下发表评论，就抛出评论?这对我来说更容易理解和排除故障.它以一种非常可预测的方式逐步浏览各行，我们根据指定的条件处理每一行.我还尝试使用变量名，让您知道它们的用途.

To prove that I don't throw out comments without backing it up with some solution / mentoring? This is much easier for me to understand and troubleshoot. It steps through the rows in a very predictable fashion and we handle each row based on specified conditions. I also try and use variable names that will let you know what they are for.

Sub Email_Macro()
'
' Email_Macro Macro
'
    Dim OutApp As Object 'email application
    Dim OutMail As Object 'email object
    Dim strBody As String 'first line of email body
    Dim strName As String 'name in the cell we are processing
    Dim strDept As String 'dept of the name we are processing
    Dim previousName As String 'previous name processed
    Dim nextName As String 'next name to process

    Dim emailWS As Worksheet 'the worksheet selected wehn running macro
    Dim nameCol As Double 'column # of names
    Dim deptCol As Double 'column # of depts
    Dim lastRow As Double 'last row of data in column
    Dim startRow As Double 'row we wish to start processing on
    Dim r As Double 'loop variable for row
    'This will be the list of departments, we will build it as we go
    Dim depList As String
    Dim strSig As String 'email signature
    strSig = "Respectfully, <br> Wookie"

    deptList = "" 'empty intitialization
    previousName = "" 'empty intialization
    nextName = "" 'empty intialization

    'Turn off screen updating
    'Application.ScreenUpdating = False
    'choose email application
    Set OutApp = CreateObject("Outlook.Application")
    'set worksheet to work on as active (selected sheet)
    Set emailWS = ThisWorkbook.ActiveSheet
    startRow = 2 ' starting row
    nameCol = 1 'col of names, can also do nameCol = emailWS.Range("A1").Column
    deptCol = 3 'col of depts, can also do deptCol = emailWS.Range("A3").Column
    '** Advantage of the optional way is if you have many columns and you don't want to count them

    'find the last row with a name in it from the name column
    lastRow = emailWS.Cells(emailWS.Rows.Count, nameCol).End(xlUp).Row

    'sort the data first before going through the email process using Range sort and a key
    'assumes these are the only columns 1 (nameCol) thru 3 (deptCol) to sort
    'assumes you are sorting based on col 1 (nameCol)
    emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, deptCol)).Sort key1:=emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, nameCol))

    'Set up our loop, it will go through every cell in the column we select in the loop
    For r = startRow To lastRow
        'Get the name and dept
        'For the name we will split around the comma and take the second part of array (right of comma)
        strName = Trim(Split(emailWS.Cells(r, nameCol), ",")(1))
        strDept = emailWS.Cells(r, deptCol)

        'if the next name is not blank (EOF)
        If emailWS.Cells(r + 1, nameCol) <> "" Then
           'assign the next name
           nextName = Trim(Split(emailWS.Cells(r + 1, nameCol), ",")(1))
        Else
           'this is your EOF exit so assume a name
           nextName = "Exit"
        End If 'Else do noting on this If

        If strName <> previousName Then
            'Set our "new" name to previousName for looping
            'process the "new" name
            previousName = strName
            'create the email object
            Set OutMail = OutApp.CreateItem(0)
            'Process as new email
            With OutMail
                .To = strName 'address email to the name
                .Subject = "Please Approve Divisions" 'appropriate subject
                deptList = strDept & "<br>" 'add the dept to dept list
                'Build the first line of email body in HTML format
                strBody = "<Font Face=calibri>Dear " & strName & ", <br><br> Please approve the following divisions:<br><br>"
            End With
        Else
            'The name is the same as the email we opened
            'Process Dept only by adding it to string with a line break
            deptList = deptList & strDept & "<br>"
        End If

        'Do we send the email and get ready for another?
        If strName <> nextName Then
            'the next name is not the same as the one we are processing and we sorted first
            'so it is time to send the email
            OutMail.HTMLBody = strBody & "<B>" & deptList & "</B>" & "<br><br>" & strSig
            OutMail.Display

        Else 'Do Nohing
        End If

Next r 'move to the next row

'nullify email reference
Set OutMail = Nothing
Set OutApp = Nothing


End Sub

如果您想防止重复的部门，那么我会这样做，您可以看到这样做的目的只有一个:

If you want to guard against duplicate departments then I would do it like this, you can see where this goes there is only one end with:

    End With
Else
    'The name is the same as the email we opened
    'Process Dept only by adding it to string with a line break
    If InStr(deptList, strDept) = 0 Then
        'Dept is not in the list so Add the department
        deptList = deptList & strDept & "<br>"
    Else
        'Do nothing, the dept is already there
    End If
End If

我想永不放弃.一切皆有可能，也许就在我们当前的技能范围之外(因此，请寻求帮助并继续学习).

I suppose never give up. Everything is possible, maybe just outside of our current skillset (so get some help and keep learning).

干杯-WWC

这篇关于从Excel Loop创建电子邮件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！