Как отправить письмо с листом Excel через marco нескольким получателям с небольшими изменениями

Question

У меня есть лист Excel с предложением продажи для нескольких получателей каждый день.В файле есть две вкладки. Теперь я создал макрос для автоматической отправки электронных писем.

В макросе есть подпрограмма для каждого дня.Теперь одна из вкладок копируется в новый рабочий лист, а не в одну ячейку с именем получателя.После этого он отправляет почту через outlook.

Sub начинается с:

    ' Copy tab to a new worksheet

Sheets("Offer").Select
Sheets("Offer").Copy
    Cells.Select


    ' Copy worksheet with only results to replace formulas

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


    ' Change the color for cell A15:C15

Range("A15:C15").Select

With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 14336204
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With


    'Format the numbers to 2 numbers after the comma
Range("D20:D47").Select
Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"


    ' Turn alerts off

Application.DisplayAlerts = False


    ' Set the author

ActiveWorkbook.BuiltinDocumentProperties("Author") = "Author name"

Затем для каждого получателя у меня есть блок, подобный этому:

    ' email1

Range("D15:H15").Select
ActiveCell.FormulaR1C1 = "name1"

ActiveWorkbook.SaveAs Filename:= _
    "C:\Aanbod\Vrijdag\Filename_receivername1", _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    'send mail

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

On Error Resume Next
With OutMail
    .to = "receiver1@domain.com"
    .CC = ""
    .BCC = ""
    .Subject = "subject here"
    .Body = ""
    .Attachments.Add ActiveWorkbook.FullName
    .Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

И чтобы завершить подпрограмму:

    ' Turn alerts back on

    Application.DisplayAlerts = True

    ' Close active window

    ActiveWindow.Close

    ' Go to tab1

    Sheets("tab1").Select

Теперь это работает, но не очень эффективно.Также по какой-то причине он не работает полностью на одном из компьютеров, на которых мы его используем.На этом компьютере он пропускает некоторые получатели, поэтому он не отправляет все электронные письма.

Теперь мне нравится создавать третью вкладку в листе предложений по продажам, в которой указаны адреса электронной почты, включая именаиз приемников.

Как я могу это сделать?

Answer 1

Итак, я перестроил код сейчас, чтобы он использовал цикл для генерации файлов и отправки писем.

Вот что я получил сейчас: Sub Maakbestanden_maandag ()

Dim Sh As Worksheet
Set Sh = ThisWorkbook.Sheets("Kopers-Maandag")

Dim Ab As Worksheet
Set Ab = ThisWorkbook.Sheets("Aanbod")

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Sheets("Aanbod").Select
Sheets("Aanbod").Copy
    Cells.Select

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Range("A15:C15").Select

With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 14336204
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

Range("D20:D49").Select
Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"

Range("C20:C49").Select
Selection.NumberFormat = "@"

Range("E20:F49").Select
Selection.NumberFormat = "0"

Columns("E:E").ColumnWidth = 8
Columns("F:F").ColumnWidth = 6

ActiveWorkbook.BuiltinDocumentProperties("Author") = "AUTHOR NAME"

Range("G50").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-30]C:R[-1]C)"

Range("G51").Select
ActiveCell.FormulaR1C1 = "=R[-1]C/12"

Dim i As Integer
Dim last_row As Long

last_row = Application.WorksheetFunction.CountA(Sh.Range("A:A"))

For i = 2 To last_row

Range("D15:H15").Select
ActiveCell.FormulaR1C1 = Sh.Range("B" & i).Value

Range("D15:H15").Select

Application.ActiveWorkbook.SaveAs Filename:=Sh.Range("C" & i).Value, _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

Next i

Application.DisplayAlerts = True

ActiveWindow.Close

MsgBox "Bestanden aangemaakt"

Call Verstuuremail_maandag

End Sub

и чем отправлять актуальные письма:

Sub Verstuuremail_maandag()

Dim Sh As Worksheet
Set Sh = ThisWorkbook.Sheets("Kopers-Maandag")

Dim OA As Object
Dim msg As Object

Set OA = CreateObject("Outlook.Application")

Dim i As Integer
Dim last_row As Long

last_row = Application.WorksheetFunction.CountA(Sh.Range("A:A"))

For i = 2 To last_row
Set msg = OA.createitem(0)

msg.To = Sh.Range("A" & i).Value
msg.Subject = "Sales offer"

msg.body = ""

If Sh.Range("C" & i).Value <> "" Then
msg.attachments.Add Sh.Range("C" & i).Value
End If

DoEvents
msg.send

Next i

MsgBox "E-mails voor maandag verstuurd"

Sheets("Veilprijzen").Select

End Sub

Теперь, когда я тестирую его, он работает хорошо, но все же иногда он останавливается на 2/3 пути при отправке писем (генерация файлов работает полностью каждый раз).

Когда он останавливается, выдается следующая ошибка: VBA ошибка 5 неверный вызов процедуры или аргумент

VBA отмечает это по адресу: msg.send

Странно, но иногда мы выполняем полный прогон в один и тот же день, с тем же кодом и информацией о клиентах, а иногда это происходит не полностью.

Любая рекомендация, чтобы решить эту проблему?