如何通過 marco 將帶有 Excel 工作表的電子郵件發送給多個經過小修改的接收者

Question

我有一張 Excel 表格，每天都有多個接收者的銷售報價。 該文件有兩個選項卡，現在我創建了一個宏，用於自動發送電子郵件。

宏每天都有一個子項。 現在，其中一個選項卡被復制到一個新的工作表，而不是它更改了一個包含接收者姓名的單元格。 之后，它通過 outlook 發送郵件。

子開頭是：

    ' 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

結束子

而不是發送實際郵件：

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 error 5 invalid procedure call or argument

VBA 將其標記為：msg.send

奇怪的是，有時我們會在同一天進行完整的運行，使用完全相同的代碼和客戶信息，有時卻不會完全運行。

有什么建議可以解決這個問題嗎？