Question

我有一张示例表，如下所示。

我有一个模块在另一个循环中的循环中遍历整个列表，检查重复的名称，然后将名称分组在一起以发送带有基于D列（分部）的附件的电子邮件。

因此，样本4将收到一封包含3个附件的电子邮件。它一直运行良好，但现在我被要求提供新的功能。他们希望在运行模块之前建立基于值（我选择是或否，C列）排除人员的能力。

原因是如果列表很长（超过1000个名称），他们可以在生成电子邮件之前设置它。我会建立一个触发器来设置这个值，但它显然是由部门中的发送者做出的任意决定。

我已经尝试在循环中构建一个逻辑stmt，如下所示，但是这样做不正常，因为if stmt出现不正确（我介入）。这意味着所有With Outmail对象都不起作用。

我假设我在if语句中错误地使用了Cells属性？或者我可以不在循环中运行if语句吗？如果无法完成，我会告诉他们他们只需要直接删除电子邮件。

我能够通过使用带有for / next设置的if语句（没有循环）来使它工作，但是无法使它与循环一起工作，这是更重要的部分。谢谢！

这是我正在讨论的主要代码。主循环然后if语句来说明是或否值：

Do While r <= rng.Rows.Count
If rng.Cells(r, 3).Value Like "?*@?*.?*" And LCase(rng.Cells(r, 3)) =     
"yes" Then

       Set OutMail = OutApp.CreateItem(0)
       End If

这是完整的子目录：

Sub EmailDivisions()
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 strName3 As Variant


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

sigString = Environ("appdata") & _
            "\Microsoft\Signatures\Divisions.htm"

    If Dir(sigString) <> "" Then
     signature = GetBoiler(sigString)
     Else
     signature = ""
    End If

    Set rng = ActiveSheet.UsedRange

r = 2


Do While r <= rng.Rows.Count
If rng.Cells(r, 3).Value Like "?*@?*.?*" And LCase(rng.Cells(r, 3)) =     
"yes" Then

       Set OutMail = OutApp.CreateItem(0)
       End If


    Set strName = rng.Cells(r, 1)
    Set strDept = rng.Cells(r, 4)
    strName2 = Left(strName, InStr(strName & " ", " ") - 1)

    With OutMail
        strFilename = Dir("\\Divisons\1a*" & strDept & "*")
        .SentOnBehalfOfName = "divisionalsend@xyz.org"
        .To = rng.Cells(r, 2).Value
        .Subject = "Monthly Divisional Report for " & strDept
        .HTMLBody = "<Font Face=calibri>" & "Dear " & strName2 & ",<br><br>" & signature
        .Attachments.Add strDir & strFilename

        'See if the next row is for the same sender.  If so, process that
        'row as well.  And then keep doing it until no more rows match
        Do While rng.Cells(r, 2).Value = rng.Cells(r + 1, 2)
            r = r + 1
            Set strDept = rng.Cells(r, 4)
            strfilename1 = Dir("\\Divisions\1a*" & strDept & "*")
            .Subject = "Monthly Divisional Report for Your Departments"
            .Attachments.Add strDir & strfilename1
        Loop
        .Display

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




End Sub



Function GetBoiler(ByVal sFile As String) As String
Dim FSO As Object
Dim ts As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function

Answer 1

想出来，这是最后一个子：

Sub EmailDivisions()
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 strName3 As Variant


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

sigString = Environ("appdata") & _
        "\Microsoft\Signatures\Divisions.htm"

If Dir(sigString) <> "" Then
 signature = GetBoiler(sigString)
 Else
 signature = ""
End If

Set rng = ActiveSheet.UsedRange

r = 2


Do While r <= rng.Rows.Count
Debug.Print LCase(rng.Cells(r, 2))
If Cells(r, 2).Value Like "?*@?*.?*" And LCase(Cells(r, 3)) = "yes" Then

       Set OutMail = OutApp.CreateItem(0)
       ElseIf Cells(r, 2).Value Like "?*@?*.?*" And LCase(Cells(r, 3)) = "no" Then GoTo ContinueLoop

       End If

Set strName = Cells(r, 1)
Set strDept = Cells(r, 4)
strName2 = Left(strName, InStr(strName & " ", " ") - 1)

With OutMail
    strFilename = Dir("\\Divisons\1a*" & strDept & "*")
    .SentOnBehalfOfName = "divisionalsend@xyz.org"
    .To = Cells(r, 2).Value
    .Subject = "Monthly Divisional Report for " & strDept
    .HTMLBody = "<Font Face=calibri>" & "Dear " & strName2 & ",<br><br>" & signature
    .Attachments.Add strDir & strFilename
.display

    'See if the next row is for the same sender.  If so, process that
    'row as well.  And then keep doing it until no more rows match
    Do While rng.Cells(r, 2).Value = rng.Cells(r + 1, 2)
        r = r + 1
        Set strDept = Cells(r, 4)
        strfilename1 = Dir("\\Divisions\1a*" & strDept & "*")
        .Subject = "Monthly Divisional Report for Your Departments"
        .Attachments.Add strDir & strfilename1
    .Display
ContinueLoop:
        Loop

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




End Sub



Function GetBoiler(ByVal sFile As String) As String
Dim FSO As Object
Dim ts As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function

基于循环内的单元格值发送电子邮件

1 个答案: