Question

搜索完这个网站后，我遇到了一个几乎完全符合我需要的宏。这个宏工作得非常好但是我想调整一些东西，但我对VBA不是很熟练。

以下是宏的链接：

http://www.rondebruin.nl/win/s1/outlook/bmail8.htm

以下是代码：

Sub Send_Row_Or_Rows_2()

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 2    'Filter column = B because the filter range start in column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=Cws.Range("A1"), _
        CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
    For Rnum = 2 To Rcount

        'Filter the FilterRange on the FieldNum column
        FilterRange.AutoFilter Field:=FieldNum, _
                               Criteria1:=Cws.Cells(Rnum, 1).Value

        'If the unique value is a mail addres create a mail
        If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

            With Ash.AutoFilter.Range
                On Error Resume Next
                Set rng = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next
            With OutMail
                .to = Cws.Cells(Rnum, 1).Value
                .Subject = "Test mail"
                .HTMLBody = RangetoHTML(rng)
                .Display  'Or use Send
            End With
            On Error GoTo 0

            Set OutMail = Nothing
        End If

        'Close AutoFilter
        Ash.AutoFilterMode = False

    Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

以下是宏中包含的功能：

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
     SourceType:=xlSourceRange, _
     Filename:=TempFile, _
     Sheet:=TempWB.Sheets(1).Name, _
     Source:=TempWB.Sheets(1).UsedRange.Address, _
     HtmlType:=xlHtmlStatic)
    .Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                      "align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

我的目标是向我的工作表中的每个电子邮件地址发送电子邮件，修改数据行中包含的第二个电子邮件地址，并包含电子邮件正文中行的数据。

因此，我的Excel工作表中的数据如下所示（列A-G）：

main-email@abc.com  -  second-email@abc.com  -  data1  -  data2  -  data3  -  data4  -  data5

A列是主要电子邮件，B列是CC的电子邮件，C-G列是电子邮件正文中包含的数据。

我目前正在上面的链接中使用示例2中的代码。该代码会针对每个唯一的电子邮件地址自动过滤我的数据，因此它不会将多封电子邮件发送到相同的地址，这是惊人的。一个问题是宏包含电子邮件正文中的整行数据（列A-G）。我希望它只显示C-G列。

            With Ash.AutoFilter.Range
                On Error Resume Next
                Set rng = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

此处添加.Offset是否允许宏仅从C-G列中获取数据？

另一个问题是宏不包括CC每个数据行中包含的第二个电子邮件地址的方法。有人可以帮助我实现这个目标吗？

也可以让宏一次准备一封电子邮件而不是一次性发送所有电子邮件吗？我的工作表有大约300个唯一的电子邮件地址，我想检查它们，然后一次一个地手动发送。有没有办法让它准备好电子邮件，并在我点击发送后继续下一个？

非常感谢!!!

Answer 1

你在这个范围的正确轨道上。你找到了合适的部分来改变。你要找的是Intersect。

 With Ash.AutoFilter.Range
     On Error Resume Next
     Set rng = Intersect(.SpecialCells(xlCellTypeVisible), Ash.Range("C:G"))
     On Error GoTo 0
 End With

关于暂停循环...如果不研究API，看来他正在使用With OutMail .Display来发送电子邮件。您可能希望尝试在该行之前放入消息框或其他内容。

对于CC，“OutMail”对象有一个CC的方法，就像它有一个用于Tos的方法。我在CC中添加了一行，假设它们存储在第二列中。

With OutMail
    .to = Cws.Cells(Rnum, 1).Value
    .CC = Cws.Cells(Rnum, 2).Value
    .Subject = "Test mail"
    .HTMLBody = RangetoHTML(rng)
    .Display  'Or use Send
End With

Answer 2

已更新：我重构了代码以清理它。 Here is my Test Stub。它应该完美无缺。

将此项与RangetoHTML. It will iterate through your list and create the emails. I left some of the options in there in case you would like to add them later. By commenting out。发送一起使用，将不会发送电子邮件。您可以在Outlook中的草稿文件夹中查看它们。

选项明确

Sub CreateEmails()
    Dim HTMLBody As String
    Dim lastRow As Long, x As Long
    Dim DataRange As Range
    Dim Subject As String

    With Worksheets("Sheet1")

        lastRow = .Range("A" & Rows.Count).End(xlUp).Row

        For x = 2 To lastRow
            If Not .Rows(x).Hidden Then
                Set DataRange = .Range(.Cells(x, 3), .Cells(x, 7))

                HTMLBody = RangetoHTML(DataRange)

                Subject = "Yadda Yadda"

                SendEmail .Cells(x, 1), .Cells(x, 2), Subject, HTMLBody
            End If
        Next

    End With



End Sub

Sub SendEmail(addressTo As String, addressCC As String, Subject As String, HTMLBody As String)
    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")

    On Error Resume Next

    With OutApp.CreateItem(0)
        .To = addressTo
        .CC = addressCC
        'OutMail.BCC = ""

        .Subject = Subject
        .HTMLBody = HTMLBody

        .Save

    End With

    On Error GoTo 0

    Set OutApp = Nothing

End Sub

Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

向工作表中的每个人发送个性化电子邮件

2 个答案: