Question

以下是我发送自动发送电子邮件的代码，但这会向每个ID发送1封电子邮件我想要的是在发送自动电子邮件之前先编译重复的id 作为下面的示例，服务标签是重复ID。道歉，不能把所有代码放在这里，因为我收到了错误。

For i = 2 To lRow
    If OOW.Sheets("WORKING FILE").Range("W" & i) = "YES" And _
    OOW.Sheets("WORKING FILE").Range("B" & i) = "Ruz" And _
    OOW.Sheets("WORKING FILE").Range("Y" & i) = "" Then

    Set rng = Nothing
    Set rngTilte = Nothing
    On Error Resume Next
    Set rngTilte = OOW.Sheets("WORKING FILE").Range("D1:X1").SpecialCells(xlCellTypeVisible)
    Set rng = OOW.Sheets("WORKING FILE").Range("D" & i & ":" & "X" & i). _
    SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

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

    Set OutApp = CreateObject("Outlook.Application")
    Set olNs = OutApp.GetNamespace("MAPI")
    Set Fldr = olNs.GetFolderFromID(EntryID, StoreID)
    Set myTasks = Fldr.items

    For Each olMail In myTasks

    If (InStr(1, olMail.Subject, Cells(i, 4), vbTextCompare) > 0) And _
    (InStr(1, olMail.Subject, Cells(i, 6), vbTextCompare) > 0) Then

功能低于

    Function RangetoHTML(rngTilte As Range, rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2013
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim NR As Long  ' Next Aavailable Row

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    ' Amended to paste two ranges
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        rngTilte.Copy
        .Cells(1, 1).PasteSpecial Paste:=8
        .Cells(1, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(1, 1).PasteSpecial xlPasteFormats, , False, False
        ' Add second range
        NR = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        rng.Copy
        .Cells(NR, 1).PasteSpecial Paste:=8
        .Cells(NR, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(NR, 1).PasteSpecial xlPasteFormats, , False, False
        ' End of add second range
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

编辑1

我尝试使用它并且工作正常。

Dim Criteria As Range
Set Criteria = OOW.Sheets("WORKING FILE").Cells(i, 4)
OOW.Sheets("WORKING FILE").Columns("D:D").AutoFilter Field:=4, Criteria1:=Criteria.Value
OOW.Sheets("WORKING FILE").Columns("Z:Z").AutoFilter _
Field:=26, Criteria1:=""

Set rng = Nothing
Set rngTilte = Nothing
On Error Resume Next
Set rngTilte = OOW.Sheets("WORKING FILE").Range("D1:X" & lRow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

现在我面临另一个问题如果在过滤器当前ID之后我发现支持列为空，我该如何移动到下一个ID。

Answer 1

有几种方法可以做到这一点 - 我假设您要为每个服务ID发送1封电子邮件，但列出所有部分（在本例中为3）

最简单的方法是按服务ID对列表进行排序，然后存储您正在处理的服务ID，并检查行，直到服务ID更改为止。然后，它会为您提供需要包含在该电子邮件中的所有行/部分。

如果您不想对列表进行排序，那么您可以存储＆＃34;完成＆＃34;服务ID（在字典或字母串中（＆＃34; | A | B |＆＃34;表示＆＃34; C＆＃34;尚未完成，因为＆＃34; | C |＆＃34;是找不到InStr））并为每个新服务ID筛选然后使用.SpecialCells查看显示的行，或者（低效）循环直到表的末尾并添加任何数据来自具有相同服务ID的行

使用重复的Word / ID发送自动电子邮件

1 个答案: