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

Question

我在编码方面需要一点帮助，可以自动发送电子邮件，但是他从电子表格中提取信息，并且在发送电子邮件时，他正在根据电子表格中的行数来复制电子邮件。 例如，在A栏中：A1名称； 答：A2José； 答：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

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