带有循环发送多封电子邮件的 VBA 代码

Question

我在编码方面需要一点帮助，我让它自动发送电子邮件，但他从电子表格中提取信息，并且在发送电子邮件时，他正在根据电子表格中的行数复制电子邮件。 Ex 在 A 栏中：A1 姓名； A：A2 何塞；答：A3 玛丽亚。该代码向 Jose 发送两封电子邮件，向 Maria 发送两封电子邮件。

Sub FeriasÀVencer()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False



  Dim r1  As Range, r2 As Range, N As Long
  Dim r3  As Range, r4 As Range, N1 As Long
  Dim r5  As Range, r6 As Range, N2 As Long
  Dim r7  As Range, r8 As Range, N3 As Long
  Dim r9  As Range, r10 As Range, N4 As Long
  Dim r11 As Range, r12 As Range, N5 As Long
  Dim r13 As Range, r14 As Range, N6 As Long
  Dim r15 As Range, r16 As Range, N7 As Long
  Dim r17 As Range, r18 As Range, N8 As Long
  Dim ws As Worksheet
  Dim wB As Workbook

  Worksheets.Add(After:=Worksheets(1)).Name = "Sheet1"


    Set wB = ActiveWorkbook
    Set ws = Sheets("Sheet1")



  Workbooks.Open "X:\TESTE1.xls"
   N = Sheets("Sheet2").Cells(Rows.count, "B").End(xlUp).Row
  N1 = Sheets("Sheet2").Cells(Rows.count, "C").End(xlUp).Row
  N2 = Sheets("Sheet2").Cells(Rows.count, "D").End(xlUp).Row
  N3 = Sheets("Sheet2").Cells(Rows.count, "G").End(xlUp).Row
  N4 = Sheets("Sheet2").Cells(Rows.count, "H").End(xlUp).Row
  N6 = Sheets("Sheet2").Cells(Rows.count, "M").End(xlUp).Row
  N5 = Sheets("Sheet2").Cells(Rows.count, "O").End(xlUp).Row
  N7 = Sheets("Sheet2").Cells(Rows.count, "P").End(xlUp).Row
  N8 = Sheets("Sheet2").Cells(Rows.count, "Q").End(xlUp).Row



  Set r1 = Sheets("Sheet2").Range("B3:B" & N)
  Set r3 = Sheets("Sheet2").Range("C3:C" & N1)
  Set r5 = Sheets("Sheet2").Range("D3:D" & N2)
  Set r7 = Sheets("Sheet2").Range("G3:G" & N3)
  Set r9 = Sheets("Sheet2").Range("H3:H" & N4)
  Set r11 = Sheets("Sheet2").Range("M3:M" & N5)
  Set r13 = Sheets("Sheet2").Range("O3:O" & N6)
  Set r15 = Sheets("Sheet2").Range("P3:P" & N7)
  Set r17 = Sheets("Sheet2").Range("Q3:Q" & N8)



  wB.Activate
  ws.Select

  Set r2 = Sheets("Sheet1").Range("A1")
  Set r4 = Sheets("Sheet1").Range("B1")
  Set r6 = Sheets("Sheet1").Range("C1")
  Set r8 = Sheets("Sheet1").Range("D1")
  Set r10 = Sheets("Sheet1").Range("E1")
  Set r12 = Sheets("Sheet1").Range("F1")
  Set r14 = Sheets("Sheet1").Range("G1")
  Set r16 = Sheets("Sheet1").Range("H1")
  Set r18 = Sheets("Sheet1").Range("I1")


  r1.Copy r2
  r3.Copy r4
  r5.Copy r6
  r7.Copy r8
  r9.Copy r10
  r11.Copy r12
  r13.Copy r14
  r15.Copy r16
  r17.Copy r18


  Columns("A:I").Select
  Columns("A:I").EntireColumn.AutoFit
  Range("A1").Select
  Columns("D:F").Select
  Selection.Font.Bold = False
  Selection.Font.Bold = True
  Range("A1").Select



  Workbooks("TEST1.xls").Close False



  For vx = 2 To 9999


  Dim k As Integer
    k = 2
    Sheets("Sheet1").Select
    Cells(k, 4).Select
    Do While ActiveCell.Value <> ""
        If (ActiveCell.Value - Now()) < 30 Then


    Dim mailDb As Object
    Dim MailDoc As Object
    Dim Body As Object
    Dim Session As Object
    Dim notesField As Object
    Dim notesEmbeddedObject As Object
    Dim AttachME As Object
    Dim EmbedObj As Object
    Dim UserName As String
    Dim pass As String




    Set Session = CreateObject("Lotus.NotesSession")



    Call Session.Initialize(pass)



    Set mailDb = Session.GETDATABASE("", "names.nsf") 



    If Not mailDb.IsOpen = True Then
        Call mailDb.Open
    End If

    UserName = Session.UserName



    Set MailDoc = mailDb.CREATEDOCUMENT
    Call MailDoc.ReplaceItemValue("Form", "Memo")


    vcod = Cells(vx, 1)
    vname = Cells(vx, 2)
    vlogin = Cells(vx, 3)
    IA = Cells(vx, 4)
    FA = Cells(vx, 5)
    LF = Cells(vx, 6)
    vglogin = Cells(vx, 9)


    If vlogin & vglogin = "" Then
    Exit For
    End If




    Call MailDoc.ReplaceItemValue("SendTo", vlogin)
    Call MailDoc.ReplaceItemValue("CopyTo", vglogin)        
    Call MailDoc.AppendItemValue("blindcopyTo", "w")




    Call MailDoc.ReplaceItemValue("Subject", "Help -  " & vname)



    Set Body = MailDoc.CREATERICHTEXTITEM("Body")
    Call Body.APPENDTEXT("Prezado Sr.(a) " & vname & " - Codigo: " & vcod)
    Call Body.ADDNEWLINE(3)
    Call Body.APPENDTEXT(" Informamos ###########################################.")
    Call Body.ADDNEWLINE(2)
    LimiteFerias = LimiteFerias - 30
    Call Body.APPENDTEXT(" Portanto ###############################################.")
    Call Body.ADDNEWLINE(1)
    Call Body.ADDNEWLINE(2)
    Call Body.APPENDTEXT(" Dúvidas ###################################################")
    Call Body.ADDNEWLINE(3)
    Call Body.APPENDTEXT(" ######################################## ")



    MailDoc.SAVEMESSAGEONSEND = True



    Call MailDoc.ReplaceItemValue("PostedDate", Now())
    Call MailDoc.SEND(False)


    Set mailDb = Nothing
    Set MailDoc = Nothing
    Set Body = Nothing
    Set Session = Nothing

        End If
        k = k + 1
        Cells(k, 4).Select
    Loop


Next

Application.DisplayAlerts = False
Sheets("Sheet1").Select
ActiveWindow.SelectedSheets.Delete

Sheets("Sheet2").Select

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True


End Sub

Answer 1

似乎您的 Do...While For...Next 循环中的循环结构不正确。 For 循环将一个变量传递给 Do 循环，该循环对所有变量都重复。您必须找到一种在使用变量时减少变量的方法，以免它们被重复使用。