Excel VBA для зацикливания данных в теле письма - PullRequest
Новая
       14

Excel VBA для зацикливания данных в теле письма

0 голосов
/ 24 февраля 2019

Я пытаюсь создать цикл в VBA, чтобы иметь несколько вариантов выбора из списка userform1 list2, когда я нажимаю командную кнопку, чтобы составить электронное письмо с каждым выбором в следующем формате.Тем не менее, я не могу понять, как получить больше, чем один выбор в теле письма.Я попытался разделить его на «среднее тело» и снова добавить код, но он просто добавляет одну и ту же запись дважды.Как я могу заставить этот цикл работать?

Private Sub CommandButton3_Click()

    Dim objOutlook As Object
    Dim objMail As Object
    Dim midBody As String
    Dim wksheet As String
    Dim i As Integer



    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    For i = 0 To ListBox2.ListCount - 1

        If ListBox2.Selected(i) = True Then
            wksheet = ListBox2.List(i)
            Sheets(wksheet).Activate

        End If


        If wksheet = "" Then
            MsgBox "Nothing is Selected"


           objMail.To = "myemail@me.com"

           'objMail.CC =

           objMail.Subject = ""


           Else

           midBody = activesheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        activesheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & activesheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
                        "Phase ECD: " & activesheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Baseline Finish: " & activesheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Previous Finish: " & activesheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Current Finish: " & activesheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Weekly Schedule Variance: " & activesheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "CUM VAR to Baseline: " & activesheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Slip Reason: " & vbNewLine & _
                        "Critical Path: " & vbNewLine & vbNewLine

           objMail.body = midBody & Sheets.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        Sheets.Range("D" & Rows.Count).End(xlUp).Value & " through " & Sheets.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
                        "Phase ECD: " & Sheets.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Baseline Finish: " & Sheets.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Previous Finish: " & Sheets.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Current Finish: " & Sheets.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Weekly Schedule Variance: " & Sheets.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "CUM VAR to Baseline: " & Sheets.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Slip Reason: " & vbNewLine & _
                        "Critical Path: " & vbNewLine & vbNewLine

        End If
        i = i + 1

    Next i


        objMail.Save

        'Close the object
        Set objMail = Nothing

    MsgBox "Done", vbInformation
End Sub

1 Ответ

0 голосов
/ 24 февраля 2019

Я внес некоторые изменения в ваш код. Сдвиг Next из For в более позднюю часть кода, чтобы включить обработку цикла.Убран избыточный midBody.Попробуйте это: 

Private Sub CommandButton3_Click()
    Dim ws As Worksheet
    Dim i As Integer
    Dim Agent As String
    Dim EmailID As String
    Dim wksheet As String
    Dim objOutlook As Object
    Dim objMail As Object


    With Me.ListBox2
    For i = 0 To .ListCount - 1
        If .Selected(i) Then
            wksheet = .List(i)
            Exit For
        End If

    End With
     If wksheet = "" Then
        MsgBox "Nothing is Selected", vbExclamation
        Exit Sub
     End If
    'r = Application.Match(wksheet, mySheet.Columns(1), 0)'choose one as per your data structure
    r = Application.Match(Agent, mySheet.Columns(1), 0)   'choose one as per your data structure


    Set ws = ThisWorkbook.ActiveSheet
    'EmailID = mySheet.Range("D" & r).Value 'Uncomment it if this is required

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    With objMail
        .To = "myemail@me.com"    ' Or  EmailID
      ' .CC =
        .subject = ""

        .Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
                 "Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Slip Reason: " & vbNewLine & _
                 "Critical Path: " & vbNewLine & vbNewLine

       '.Display
       '.Send
        .Save
    End With
    Next i
    Set objMail = Nothing
    Set objOutlook = Nothing

    MsgBox "Done", vbInformation

  End Sub

РЕДАКТИРОВАТЬ : еще одна версия кода, которая работает на моем конце.Я не создал listbox, но симулировал его работу.Эта программа работает правильно и отправляет электронные письма несколько раз.Удалите переменную k согласно вашему listbox коду.Это только для проверки правильности зацикливания птограммы.Более раннюю версию программы можно настроить в соответствии с вашими требованиями, если вы предоставите образцы данных, например структуру listbox, откуда она выбирает электронный адрес получателя, образцы данных вашего рабочего листа и т. Д. 

Private Sub Command3_Click()
Dim subject As String, Body As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim ws As Worksheet
Dim k As Integer

  On Error Resume Next
   Set ws = ThisWorkbook.ActiveSheet
  Set OutApp = GetObject(, "Outlook.Application")
  If OutApp Is Nothing Then
    Set OutApp = CreateObject("Outlook.Application")
  End If
  On Error GoTo 0
  k = 4 ' remove it only for checking correct loop
  For intCurrentRow = 0 To k - 1  'List2.ListCount change k to List2.ListCount
     Set OutMail = OutApp.CreateItem(olMailItem)

     With OutMail
        ' List2.Selected(intCurrentRow) = True ' This is to be commented out after trials for looping

        .To = "abc@gmail.com"
        .subject = "Test 2nd time Email"
        .Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
                 "Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Slip Reason: " & vbNewLine & _
                 "Critical Path: " & vbNewLine & vbNewLine

        .Send
     End With
  Next intCurrentRow

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Снимок Outlook показывает, что он зациклен правильно, что было вашей главной проблемой.outlookemails-snapshot РЕДАКТИРОВАТЬ2: Более ранняя версия программы, смоделированная на моем конце на основе выборки, работает правильно и отправляет несколько писем.Я не имею представления о ваших настройках данных, которые были смоделированы для циклического воспроизведения, что было вашей главной проблемойПожалуйста, попробуйте программу как есть, сохраните копию и затем внесите соответствующие коррективы для вашей конкретной ситуации с данными.orignal_rerun

    Private Sub CommandButton3_Click()
    Dim ws As Worksheet
    Dim i As Integer
    Dim Agent As String
    Dim EmailID As String
    Dim wksheet As String
    Dim objOutlook As Object
    Dim objMail As Object


   ' With Me.ListBox2
    For i = 1 To 3
    'For i = 0 To .ListCount - 1
     '   If .Selected(i) Then
      '      wksheet = .List(i)
       '     Exit For
       ' End If

    'End With
     If wksheet = "hello" Then
        MsgBox "Nothing is Selected", vbExclamation
        Exit Sub
     End If
    'r = Application.Match(wksheet, mySheet.Columns(1), 0)'choose one as per your data structure
   ' r = Application.Match(Agent, mySheet.Columns(1), 0)   'choose one as per your data structure


    Set ws = ThisWorkbook.ActiveSheet
    'EmailID = mySheet.Range("D" & r).Value 'Uncomment it if this is required

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    With objMail
        .To = "abc@gmail.com"    ' Or  EmailID
      ' .CC =
        .subject = "original test"

        .Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
                 "Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Slip Reason: " & vbNewLine & _
                 "Critical Path: " & vbNewLine & vbNewLine

       '.Display
       .Send
        '.Save
    End With
    Next i
    Set objMail = Nothing
    Set objOutlook = Nothing

    MsgBox "Done", vbInformation

  End Sub
...