Question

我需要一些编码帮助，我让它自动发送电子邮件，但他从电子表格中提取信息，在发送电子邮件时，他根据电子表格中的行数复制电子邮件。 Ex在A栏：A1名称;答：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 ...在For ... Next循环中的while循环没有正确结构化。 For循环将变量传递给Do循环，对所有变量重复该循环。您必须找到一种方法来减少变量，因为它们不会被重用。

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

1 个答案: