时间戳

首页 > 解决方案 > 宏通过电子邮件发送除两个工作表之外的所有工作表

vba - 宏通过电子邮件发送除两个工作表之外的所有工作表

问题描述

我有一个工作簿，其中包含不同客户的价目表，每周我必须将所有价目表通过电子邮件发送给相应的客户。这是一项相当耗时的任务，我一直在尝试使用 VBA 将其自动化。在大多数情况下，我通过使用 Ron de Bruin 的代码取得了成功，但我遇到了一个我似乎无法解决的问题，所以我希望能了解我哪里出错了。

如前所述，此工作簿包含多个不同的价格表，它们都需要发送给不同的客户。我已经稍微修改了这段代码以满足我的需要（例如只处理可见单元格，包括电子邮件签名等）。我对此代码所做的一项重大更改是循环遍历包含收件人地址的范围（如下所示）。

我目前面临的问题是此代码适用于除两张表之外的所有工作表。它将为两个问题表创建一封电子邮件，但范围（A1：L85）中的任何内容都不会粘贴到电子邮件中 ​​- 它只是发送一封除了我的签名之外没有正文的电子邮件。使情况变得更糟（或更有趣）的是这两个问题表出现在工作表的“中间”。假设问题表 1 = PS_1 和问题表 2 = PS_2 它会是这样的：

WS_1, WS_2, ..., WS_14, PS_1, WS_16, PS_2, WS_18, ..., WS_32

所以我想知道为什么它只弄乱了这两张纸，以及如何解决它。

我在下面包含了我的所有代码（Ron de Bruin 网站上的 RangetoHTML 和一个获取工作表名称的函数除外）：

Sub email()
' this is intended to speed up the code
With Excel.Application
        .ScreenUpdating = False
        .Calculation = Excel.xlCalculationManual
        .EnableEvents = False
End With

Dim OutApp As Object
Dim OutMail As Object

Dim rng As Range 'this is the range of the price list
Dim erng As Range 'this is the range of email addresses
Dim cell As Range

Dim wsnames() As String 'worksheet names are stored in an array
Dim pricedate As String 'the week of prices the user provides (e.g. July 1st - July 7th)
Dim tsheets As Integer 'total sheets

'counting variables
Dim m As Integer
Dim n As Integer

Set OutApp = CreateObject("Outlook.Application")

'initializing variables
Set rng = Nothing

'initializing variables
n = 0

pricedate = InputBox("Enter the week the prices are for (e.g. July 10th - July 15th): ", "Week")

If pricedate = vbNullString Then Exit Sub 'if the user presses cancel it will stop the macro

tsheets = ActiveWorkbook.Worksheets.Count 'finds how many sheets are in the workbook to adjust the size of the array

ReDim wsnames(tsheets) 'resizes the size of the array

wsnames = storewsnames 'passing the sheet names to wsnames

For m = 1 To tsheets - 1

    If wsnames(m) = "Atwood" Then Exit For 'looks for the index of worksheet "Atwood", and once it's found it exits the loop

Next m

For n = m To tsheets - 1 'sets n to the index of "Atwood"

    If Sheets(wsnames(n)).Visible = True Then 'only will send emails to visible sheets

        With Sheets(wsnames(n))

            Set rng = .Range("A1:L85")

            Set erng = .Range("M71:M85")

        End With

        On Error GoTo cleanup

        For Each cell In erng 'searches the cells in the email addresses range

            If cell.Value Like "?*@?*.?*" Then 'looks
            '_for email addresses where the email addresses are saved

                Set OutMail = OutApp.CreateItem(0)

                On Error Resume Next

                 With OutMail

                    .Display
                    .To = ""
                    .CC = ""
                    .BCC = cell.Value
                    .Subject = "CM Weekly Prices - " & wsnames(n)
                    .HTMLBody = "<BODY style=font-size:11pt;font-family:Calibri> Hi, " & _
                        "<br><br>" & "Below are the prices for the week of " & pricedate & _
                        "." & RangetoHTML(rng) & "Thank you, </BODY><br>" & .HTMLBody
                    .Send

                End With

                On Error GoTo cleanup
                Set OutMail = Nothing

            End If

        Next cell

    End If

Next n

' this is intended to speed up the code
With Excel.Application
        .ScreenUpdating = True
        .Calculation = Excel.xlCalculationAutomatic
        .EnableEvents = True
End With

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True

End Sub

我对使用 VBA 发送电子邮件非常不熟悉，所以我一直非常依赖我使用的代码，并试图只进行微小的更改。

如果大家还有什么需要，或者不清楚的地方请告诉我！

标签： vbaexcel

解决方案

推荐阅读