VBA代碼循環發送多封電子郵件

Question

我需要一些編碼幫助，我讓它自動發送電子郵件，但他從電子表格中提取信息，當發送電子郵件時，他根據行數複製電子郵件在電子表格中。 Ex列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

似乎是你的... While ... Next循環內的while循環沒有正確的結構。 For循環將一個變量傳遞給Do循環，對所有變量重複該循環。你必須找到一種減少變量的方法，因爲它們不會被重複使用。