从Excel循环创建电子邮件

Question

我有这张样本表：

我的代码目前通过并根据H列中的名称创建电子邮件。因此Approver1会收到一封电子邮件给所有人。我已经把它重复删除了他们的员工姓名。示例：审批者1收到一封电子邮件，上面写着“请为下面的所有员工批准时间：”然后会有一个名称列表... Sample1，Sample2和Sample3。对于每个审批人，工作表通常都有欺骗员工，如上面的表格所示。

该代码适用于第一组欺骗名称（连续可以有多达10个相同的批准者，都可以获得一封电子邮件），然后通过任何单打运行都可以正常运行。

当它到达下一组重复审批者时，它会跳过该组中的第一行，然后为每个其他部门创建电子邮件;所以它会跳过一行，直到它到达欺诈审批部分的末尾。因此，从工作表中，approver1会将他的电子邮件全部设置好，然后approver2将获得她的电子邮件，但然后审批者3变得一团糟。

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

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

Answer 1

这是一个小助手存根，用于从A列中查找唯一列表，并将该列表放在C列中。基于按钮单击。根据需要修改。

Option Explicit

Private Sub CommandButton1_Click()
 Dim thisWS As Worksheet
 Dim firstRow As Double
 Dim lastRow As Double
 Dim workCol As Double
 Dim dataRange As Range
 Dim uniqueLast As Double
 Dim uniqueCol As Double
 Dim i As Double
 Dim y As Double
 Dim Temp As String
 Dim found_Bool As Boolean

 Set thisWS = ThisWorkbook.Worksheets("Sheet2")
 workCol = thisWS.Range("A1").Column
 firstRow = 1
 uniqueLast = 1
 uniqueCol = thisWS.Range("C1").Column
 lastRow = thisWS.Cells(thisWS.Rows.Count, workCol).End(xlUp).Row

 For i = firstRow To lastRow
    Temp = Trim(UCase(thisWS.Range(Cells(i, workCol), Cells(i, workCol))))
    Temp = Replace(Temp, "#", "")
    found_Bool = False
    For y = 1 To uniqueLast
        If Temp = thisWS.Range(Cells(y, uniqueCol), Cells(y, uniqueCol)) Then
          found_Bool = True
        Else ' Do nothing
        End If


    Next y

    If found_Bool = False Then
          thisWS.Range(Cells(uniqueLast + 1, uniqueCol), Cells(uniqueLast + 1, uniqueCol)) = Temp
          uniqueLast = uniqueLast + 1
    Else
    End If

 Next i
End Sub

执行此操作后，您可以在非唯一列中查找每个名称，并获取相应的主题或其他信息部门。

你想要的实际上是VBA中的一个支点（名称和部门，你可以只是vba枢轴，这有点棘手但非常可行。

'***************************************************

好吧，看看斯科特有什么，它非常可行。关于枢轴表本身的一些“帮手”。再次，要么命名表，只是更新范围或删除它，并每次都进行。做到项目我每次都删除它并继续使用相同的空间在picot之后制作picot，每次打开工作簿时这个空白区域都很清楚。

这是我创建销售数据的一个支点，跟我一起，我实际上将数据透视后的数据复制到值然后添加列来执行计算，然后我将其移动到报表，删除数据透视表和工作表，基本上这一切都远离用户点击按钮时看到的内容：

   '***************************
    'Add Sales Pivot Table
   'Last DR is the last data row, you can see it done several times, in the code below, once you do it you will always do it
   'CalcSheet is the name of the worksheet in the workbook I am working on
   'The range here is defined in Range Format, you could use a named range or use .Range(Cells(row,col),Cells(row,col)) there are several ways
   'I name the pivot table upon creation so I can manipulate it better
   'I specify the target cell, upper left with which to begin the pivot table

   ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        CalcSheet.Range("K14:AY" & LastDR), Version:=xlPivotTableVersion15).CreatePivotTable _
        TableDestination:=CalcSheet.Range("CA37"), TableName:="SalesPVT", DefaultVersion _
        :=xlPivotTableVersion15

我以我想要的格式设置透视图，然后根据其中一个字段对其进行排序：

With CalcSheet.PivotTables("SalesPVT").PivotFields("Salesperson")
    .Orientation = xlRowField
    .Position = 1
End With

With CalcSheet.PivotTables("SalesPVT").PivotFields("Customer")
    .Orientation = xlRowField
    .Position = 2
End With

With CalcSheet.PivotTables("SalesPVT").PivotFields("DD Rev")
    .Orientation = xlDataField
    .Function = xlSum
    .NumberFormat = "$#,##0"
End With

With CalcSheet.PivotTables("SalesPVT").PivotFields("Job Days")
    .Orientation = xlDataField
    .Function = xlSum
    .NumberFormat = "#,##0"
End With

CalcSheet.PivotTables("SalesPVT").PivotFields("Salesperson").AutoSort _
    xlDescending, "Sum of DD Rev"

也许有另一种方法，但现在我不知道数据透视表（行）的尺寸吗？所以我在这里定义它们是基于我放置数据透视表的第一列和我在创建中指定的锚范围：

'Find the last row of Pivot table Data

Dim LastPVTrow As Double
Dim FirstPVTrow As Double
Dim NumPVTrows As Double
Dim PivCol As Double

PivCol = CalcSheet.Range("CB37").Column

FirstPVTrow = CalcSheet.Range("CB37").Row
LastPVTrow = CalcSheet.Cells(Rows.Count, PivCol).End(xlUp).Row
NumPVTrows = LastPVTrow - FirstPVTrow

在这里，我根据数据透视数据在其他地方创建了一个列，如果您需要，您的电子邮件可能就在这里： '制作Avg Rev / Job Day专栏

    For i = 1 To NumPVTrows ' four columns in this table
        CalcSheet.Range("CD" & (100 + i)).NumberFormat = "$#,##0"
        If CalcSheet.Range("CC" & (FirstPVTrow + i)) <> 0 Then
            CalcSheet.Range("CD" & (100 + i)) = CalcSheet.Range("CB" & (FirstPVTrow + i)) / CalcSheet.Range("CC" & (FirstPVTrow + i))
        Else
            CalcSheet.Range("CD" & (100 + i)) = 0
        End If
   Next i

'在这里，我要留下一堆东西，但是它会在我的桌子上放置标题，只是缺少枢轴并添加更多的列和计算，根据指定的范围计算值等，并找到平均值

'然后我复制数据透视表并将其删除，每次单击按钮并选择新工作簿进行处理时都会发生

'copy pivot table to get rid of it
 CalcSheet.PivotTables("SalesPVT").TableRange1.Copy
'Paste it as values with formatting
CalcSheet.Range("CA100").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Delete Sales Pivot from the file
 CalcSheet.PivotTables("SalesPVT").TableRange1.Delete

'Clear Work Space
CalcSheet.Range("CA1:CN500").Clear

一旦我处理了销售人员，我就会在相同的工作临时空间中由客户再次执行此操作，根据数据构建一个表格，在下面创建新的列和标题，将表格复制为值，然后将其放入报告，删除所有，下次去。我在导出之前格式化我的小桌子：粗体标题，灰色在销售人员或客户上，总计行是蓝色，我右边对齐单元格中的数字，有很多代码留下来专注于枢轴。

所以这里是为客户构建表格的类似枢轴代码

'***************************************
'Make the Customer Pivot and table
'***************************************

ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        CalcSheet.Range("K14:AY" & LastDR), Version:=xlPivotTableVersion15).CreatePivotTable _
        TableDestination:=CalcSheet.Range("CA37"), TableName:="CustPVT", DefaultVersion _
        :=xlPivotTableVersion15

    With CalcSheet.PivotTables("CustPVT").PivotFields("Customer")
        .Orientation = xlRowField
        .Position = 1
    End With

    With CalcSheet.PivotTables("CustPVT").PivotFields("DD Rev")
        .Orientation = xlDataField
        .Function = xlSum
        .NumberFormat = "$#,##0"
    End With

    With CalcSheet.PivotTables("CustPVT").PivotFields("Job Days")
        .Orientation = xlDataField
        .Function = xlSum
        .NumberFormat = "#,##0"
    End With

'Find the last row of Pivot table Data

FirstPVTrow = CalcSheet.Range("CA37").Row
LastPVTrow = CalcSheet.Cells(Rows.Count, PivCol).End(xlUp).Row
'LastPVTrow = CalcSheet.Range("CB37:CB500").Find((0), LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
NumPVTrows = LastPVTrow - FirstPVTrow

等。等等。 。 。

我相信这里的用户更优雅。 我努力寻找可读且通常可以理解的代码（希望是其他人）并且受我的技能限制，你必须在几个月或几年之后再回到这个问题，相信我看起来与你“生活在创造“花点时间给自己留下面包屑，给变量和表格命名，这样它们才有意义。尝试使用命名范围而不是“硬编码”范围，我知道我在这里做了，就像我说的那样。 。 。不像我那样。我通常只在稍后会被删除和擦除的区域中执行此操作。没有任何借口，但我正忙着这个。

干杯

Answer 2

如果你透视数据，这里有一种循环遍历枢轴以通过名称获取唯一信息的方法。

透视数据

defect related

<强>代码

Listbox

Answer 3

我删除了之前的答案，然后在您需要该信息时将其取消删除。为了不混淆任何人，从OP的代码构建的答案如下。

免责声明：我不喜欢Do While中的增量代码风格，它使得很难追逐错误，但我理解其意图。我已经在我的大脑工作的方式中包含了这个代码，也许更好的编码风格，你就是法官。

好吧@learningthisstuff我弄清楚发生了什么，代码假定名字已经排序。没有提供的一件事是，如果部门名称是相同的，它将被多次列出，如果存在不同代码的欺骗，部门是否总是对于一个人而言是唯一的（没有欺骗？）。

此代码可以正常运行，我只是将其作为虚拟集上的宏运行。重要的是排序和增量逻辑，我改变了一些东西，使其在整个过程中更具可读性/可理解性。

我希望这可以帮助你，你可以随着事情的变化进行修改。

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

截图：

要证明我不会在没有用一些解决方案/指导支持的情况下抛弃评论？这对我来说更容易理解和排除故障。它以非常可预测的方式遍历行，我们根据指定的条件处理每一行。我也尝试使用变量名称，让你知道它们的用途。

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

如果你想防止重复的部门，那么我会这样做，你可以看到这里只有一个结束：

    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

我想永不放弃。一切皆有可能，也许只是在我们当前的技能组合之外（所以得到一些帮助并继续学习）。

干杯 - WWC

Answer 4

我正在使用不同的技术来解决Excel中的相同问题。首先，我有一个函数来打开一个新的ADODB-Recordset：

Function RST_Excel(strExceldatei As String, strArbeitsblatt As String, strWHERE As String, Optional strBereich As String, _
                   Optional strDatenfelder As String = "*") As ADODB.Recordset

Dim i As Integer
Dim rst As ADODB.Recordset
Dim strConnection As String
Dim strSQL As String


On Error GoTo sprFehler

strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & strExceldatei

If global_con Is Nothing Then

   Set global_con = New ADODB.Connection

   With global_con
        .Open strConnection
        End With

   End If

strSQL = "SELECT " & strDatenfelder & " FROM [" & strArbeitsblatt & "$" & strBereich & "] WHERE " & strWHERE

Set rst = New ADODB.Recordset

With rst
     .Source = strSQL
     .CursorLocation = adUseClient
     .ActiveConnection = global_con
     .Open
     Set RST_Excel = rst
     End With

sprEnde:

Set rst = Nothing

Exit Function


sprFehler:
Set rst = Nothing

Set RST_Excel = Nothing

End Function

然后我从另一个例程中打开ADODB-Recordset：

Dim strWHERE As String
Dim strFields As String
Dim rst_Recipients As ADODB.Recordset

strWHERE = "Surname IS NOT NULL AND Emailadress IS NOT NULL"
strFields = "Surname, Name, Emailadress, SMIME"

Set rst_Empfänger = RST_Excel(ThisWorkbook.FullName, "Email", strWHERE, "A1:M1000", strFields)

当查询作为SQL语句传递时，您还可以传递Statement以获得唯一结果。

我的进步是我可以轻松地通过Recordset：

With rst
     .movefirst

     do until .eof
        debug.print .fields("surename").value
        .movenext
        loop

end with

Answer 5

我认为你可以用它来做你想做的事。

在Sheets（“Sheet1”）中创建一个列表：

In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

宏将遍历“Sheet1”中的每一行，如果B列中有电子邮件地址 和C列中的文件名：Z它将创建一个包含此信息的邮件并发送。

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub