Question

我正在尝试将一些Ron de Bruin excel代码组合成一个可用的宏，并取得了相当不错的成功，除了我认为可能是一个我无法解决的简单问题。

代码工作并弹出一封电子邮件，但有两件事是错误的：

1 - 我希望从与所述人员电子邮件“行”绑定的超链接工作簿中选择的单元格（已复制）。我已经尝试了Range（cell.Row，“B”），但这不起作用，将所有内容复制到电子邮件中。

2 - 它不会进入列表中的下一个单元格（名称）。我有“下一个单元格”，但它会覆盖第一封电子邮件。不创建新的。

任何帮助将不胜感激！谢谢！

Sub Email_Test()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim StrBody2 As String

    StrBody2 = "Text goes here" & "<br><br>" & _
               "Thank you," & "<br>" & _
               "   My name" & "<br><br>"

 '*********
 'Mail Part
 '*********
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


   For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "E").Value) = "yes" _
           And LCase(Cells(cell.Row, "F").Value) <> "send" Then

                Set rng = Nothing
                On Error Resume Next

                    Range("B2").Select
                    Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=False
                    ActiveSheet.Range("$A$1:$L$50").AutoFilter Field:=3, Criteria1:= _
                        "=CAL EXPIRED", Operator:=xlOr, Criteria2:="=Quarantine"
                Set rng = rows("1:50")
                Sheets("MailInfo").Select
                On Error GoTo 0

                With Application
                    .EnableEvents = True
                    .ScreenUpdating = True
                End With

    On Error Resume Next
    With OutMail
        .to = cell.Value
        .CC = ""
        .BCC = ""
        .Subject = "Reminder Email"
        .HTMLBody = "Dear " & cell.Offset(0, -1).Value & "," & "<br><br>" & _
                    "More text <BR>" & _
                    StrBody1 & RangetoHTML(rng) & StrBody2
        .Display     'or use .Send
     End With

        Cells(cell.Row, "F").Value = "Send"
    End If
 Next cell
    On Error GoTo 0


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

将选定的单元格发送到电子邮件列表（Excel）

0 个答案: