Блог

Главная - Вопросы по программированию - Как создать несколько отдельных электронных писем из листов Excel?

Как создать несколько отдельных электронных писем из листов Excel?

#excel #vba #loops #email #outlook

Вопрос:

Я хочу получить данные из указанных листов в книге Excel, а затем создать отдельные электронные письма с каждого отдельного листа.

Прямо сейчас код сгенерирует первое электронное письмо с первого листа, а затем пролистает оставшиеся вкладки без создания дополнительных электронных писем. Я могу подтвердить, что код продвигается дальше первого листа с помощью MsgBox ActiveSheet.Name проверки.

Я использую RangetoHtml функцию Рона Дебруина в отдельном модуле.

 Sub ClientEvent_Email_Generation()

Dim OutApp As Object
Dim OutMail As Object
Dim count_row, count_col As Integer
Dim Event_Table_Data As Range
Dim Event2_Table_Data As Range
Dim strl As String, STR2 As String, STR3 As String
Dim WS As Worksheet
Dim I As Integer

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

For Each WS In ThisWorkbook.Sheets

    WS.Activate

    If WS.Name <> "DATA INPUT" And WS.Name <> "FORMATTED DATA TABLE" And WS.Name <> "REP CODE MAPPING TABLE" And WS.Name <> "IDEAS TAB" And WS.Name <> "REFERENCE" Then

        count_row = WorksheetFunction.CountA(WS.Range("A10", Range("a10").End(xlDown)))
        count_col = WorksheetFunction.CountA(WS.Range("A10", Range("a10").End(xlToRight)))

        Set Event_Table_Data = WS.Cells.Range(Cells(9, 1), Cells(count_row, count_col)) 
        Set Event2_Table_Data = Sheets("w61").Range(Cells(9, 1), Cells(count_row, count_col)) 

        str1 = "<BODY style=font-size:12pt;font-family:Times New Roman>" amp; _
          "Hello " amp; Range("L3").Value amp; ",<br><br>The following account(s) listed below appear to have an upcoming event(s)<br>"
        STR2 = "<br> Included are suggestions for an activity which may fit your client's needs.<br>"
        STR3 = "<br> You may place an order, or contact us for alternate ideas if these don't fit your client."

        On Error Resume Next
        With OutMail
            .To = WS.Range("l4").Value
            .cc = ""
            .bcc = ""
            .Subject = "Upcoming Event In Your Clients' Account(s)"
            .display
            .HTMLBody = str1 amp; RangetoHTML(Event_Table_Data) amp; STR2 amp; RangetoHTML(Event2_Table_Data)amp; STR3 amp; .HTMLBody
            .SEND
        End With
        On Error GoTo 0
        
        Set OutMail = Nothing
        Set OutApp = Nothing

        MsgBox ActiveSheet.Name ‘Used for testing purposes only

    End If
Next WS

End Sub

Комментарии:

1. Это On Error Resume Next приведет к ошибкам при глотании, которые могут возникнуть. Я предлагаю вам удалить это (вместе с On Error Goto 0 устранением неполадок.

2. Вы уничтожаете объекты OutMail и OutApp в конце каждого цикла, т. е. первый цикл выполняется нормально, а второй и следующий относятся к уничтоженным объектам. Но у вас отключены сообщения об ошибках, и вы не можете видеть, что происходит.

3. Самое простое, что можно сделать, это удалить строки Set OutMail = Nothing и Set OutApp = Nothing

4. Cells(count_row, count_col) вероятно, это должно быть Cells(count_row 9, count_col) в настройке диапазонов данных.

5. Переместите линию Set OutMail = OutApp.CreateItem(0) внутрь петли, прежде чем With OutMail

Метки: