Excel 电子邮件表范围到相同的地址_Excel_Vba

Excel 电子邮件表范围到相同的地址

excel vba

Excel 电子邮件表范围到相同的地址,excel,vba,Excel,Vba,因此，目前我的代码也几乎达到了我喜欢的效果目前，它将相同的电子邮件分组在一起，并将不同的电子邮件发送给不同的人。但在电子邮件中，我尽量不包括A栏，这是他们的电子邮件 For Each cell In WS.Columns("A").Cells.SpecialCells(xlCellTypeConstants) If cell.Value Like "?*@?*.?*" Then 'check if this email address has been us

因此，目前我的代码也几乎达到了我喜欢的效果

目前，它将相同的电子邮件分组在一起，并将不同的电子邮件发送给不同的人。但在电子邮件中，我尽量不包括A栏，这是他们的电子邮件

    For Each cell In WS.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" Then

        'check if this email address has been used to generate an outlook email or not
        If dict.exists(cell.Value) = False Then

            dict.Add cell.Value, "" 'add the new email address
            Set OutMail = OutApp.CreateItem(0)
            Set rng = WS.UsedRange.Rows(1)

            'find all of the rows with the same email and add it to the range
            For Each cell2 In WS.UsedRange.Columns(1).Cells
                If cell2.Value = cell.Value Then
                    Set rng = Application.Union(rng, WS.UsedRange.Rows(cell2.Row))
                End If
            Next cell2

我试图修改上面的代码，但似乎无法解决。。有人能帮我吗

完整代码：

    Option Explicit


Sub Test1()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim dict As Object 'keep the unique list of emails
    Dim cell As Range
    Dim cell2 As Range
    Dim rng As Range
    Dim i As Long
    Dim WS As Worksheet
    Dim Signature As String

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    Set dict = CreateObject("scripting.dictionary")
    Set WS = ThisWorkbook.Sheets("Sheet1") 'Current worksheet name

    On Error GoTo cleanup
    For Each cell In WS.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then

            'check if this email address has been used to generate an outlook email or not
            If dict.exists(cell.Value) = False Then

                dict.Add cell.Value, "" 'add the new email address
                Set OutMail = OutApp.CreateItem(0)
                Set rng = WS.UsedRange.Rows(1)

                'find all of the rows with the same email and add it to the range
                For Each cell2 In WS.UsedRange.Columns(1).Cells
                    If cell2.Value = cell.Value Then
                        Set rng = Application.Union(rng, WS.UsedRange.Rows(cell2.Row))
                    End If
                Next cell2

                On Error Resume Next
                With OutMail
                    .SentOnBehalfOfName = ""
                    .GetInspector ' ## This inserts default signature
                        Signature = .HTMLBody ' ## Capture the signature HTML
                    .To = cell.Value
                    .CC = ""
                    .Subject = "Reminder"
                    .HTMLBody = "<BODY style=font-size:12pt;font-family:Calibri><font color=#000000>Hi " & WorksheetFunction.Proper(RemoveNumbers(Left((cell.Value), InStr((cell.Value), ".") - 1))) & ", " & "<br><br>" & "Please see your trip numbers and estimated cost below:" & vbNewLine & vbNewLine & RangetoHTML(rng) & Signature & "</font></BODY>"
                    .Display
                End With

                On Error GoTo 0
                Set OutMail = Nothing
            End If
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Function RemoveNumbers(Txt As String) As String
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "[0-9]"
RemoveNumbers = .Replace(Txt, "")
End With
End Function

Function RangetoHTML(rng As Range)
    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

选项显式
子测试1（）
Dim OutApp作为对象
将邮件变暗为对象
Dim dict As Object“保留唯一的电子邮件列表
暗淡单元格作为范围
暗淡的单元格2 As范围
变暗rng As范围
我想我会坚持多久
将WS设置为工作表
作为字符串的数字签名
Application.ScreenUpdating=False
Set-OutApp=CreateObject（“Outlook.Application”）
Set dict=CreateObject（“scripting.dictionary”）
将WS=ThisWorkbook.Sheets（“Sheet1”）设置为当前工作表名称
关于错误转到清理
对于WS.Columns（“A”）.Cells.SpecialCells（xlCellTypeConstants）中的每个单元格
如果单元格的值像“*@*。？*”那么
'检查此电子邮件地址是否已用于生成outlook电子邮件
如果dict.exists（cell.Value）=False，则
dict.Add cell.Value“”，添加新的电子邮件地址
Set-OutMail=OutApp.CreateItem（0）
Set rng=WS.UsedRange.Rows（1）
'查找具有相同电子邮件的所有行并将其添加到范围
对于WS.UsedRange.Columns（1.Cells）中的每个cell2
如果cell2.Value=cell.Value，则
Set rng=Application.Union（rng，WS.UsedRange.Rows（cell2.Row））
如果结束
下一单元2
出错时继续下一步
发邮件
.SentonBehalfName=“”
.GetInspector'##此选项插入默认签名
签名=.HTMLBody'##捕获签名HTML
.To=单元格.Value
.CC=“”
.Subject=“提醒”
.HTMLBody=“Hi”和WorksheetFunction.property（删除编号（左（（cell.Value）、InStr（（cell.Value），“）-1））&“，”和“

”&“请在下面查看您的行程编号和估计成本：”&vbNewLine&vbNewLine&RangetoHTML（rng）&Signature&“
.展示
以
错误转到0
发送邮件=无
如果结束
如果结束
下一个细胞
清理：
设置应用程序=无
Application.ScreenUpdating=True
端接头
函数RemoveNumbers（Txt作为字符串）作为字符串
使用CreateObject（“VBScript.RegExp”）
.Global=True
.Pattern=“[0-9]”
RemoveNumbers=.Replace（Txt，“”）
以
端函数
函数RangetoHTML（rng作为范围）
作为对象的Dim fso
将T作为对象
将文件设置为字符串
将TempWB设置为工作簿
TempFile=Environ$（“temp”）和“\”格式（现在是“dd-mm-yy h-mm-ss”）和“.htm”
'复制范围并创建一个新工作簿，以超过中的数据
收到
Set TempWB=工作簿。添加（1）
带临时工作表（1）
.单元格（1）.粘贴特殊粘贴：=8
.单元格（1）.粘贴特殊值，False，False
.单元格（1）.粘贴特殊xlPasteFormats，False，False
.单元格（1）。选择
Application.CutCopyMode=False
出错时继续下一步
.DrawingObjects.Visible=True
.DrawingObjects.Delete
错误转到0
以
'将工作表发布到htm文件
使用TempWB.PublishObjects.Add（_
SourceType:=xlSourceRange_
文件名：=临时文件_
工作表：=临时工作表（1）.名称_
来源：=TempWB.Sheets（1）.UsedRange.Address_
HtmlType:=xlHtmlStatic）
.发布（真实）
以
'将htm文件中的所有数据读入RangetoHTML
设置fso=CreateObject（“Scripting.FileSystemObject”）
设置ts=fso.GetFile（TempFile）.OpenAsTextStream（1，-2）
RangetoHTML=ts.readall
关闭
RangetoHTML=Replace（RangetoHTML，“align=center x:publishsource=”_
“align=left x:publishsource=”）
“关闭TempWB
TempWB.Close savechanges:=False
'删除此函数中使用的htm文件
杀死临时文件
设置ts=无
设置fso=无
设置TempWB=Nothing
端函数

一个选项是使用

相交

和

调整大小

在创建

rng

的循环之后，但在将

rng

传递到

RangetoHTML

之前：

With WS.UsedRange
    Set rng = Intersect(rng, .Columns(2).Resize(,.Columns.Count - 1))
End With

谢谢肯定是我要找的