Excel VBA宏将电子邮件发送到范围内的唯一用户

3 回答

• 0

  你可以用不同的方式做到这一点，但我只是给你一个快速的答案来解决你的问题 . 我使用Ron de Bruin开发的函数将范围转换为html体 .

  • 我删除了其中一个条件来检查A列中单元格的内容，因此请确保将其放回并使用您自己的数据进行测试

  • 我使用字典存储我们生成outlook实例的电子邮件，因此如果在其他单元格中您有相同的电子邮件，则不会再生成电子邮件

  • 你需要在outlook新项目中使用html body而不是body，这样你就可以有更多的选项来快速粘贴你的内容并对其进行格式化（颜色，大小，字体等）

  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
  
      Application.ScreenUpdating = False
      Set OutApp = CreateObject("Outlook.Application")
      Set dict = CreateObject("scripting.dictionary")
      Set WS = ThisWorkbook.Sheets("Sheet1") 'change the name of the sheet accordingly
  
      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
                      .To = cell.Value
                      .Subject = "Reminder"
                      .HTMLBody = "Hi, please find your account permissions below:" & vbNewLine & vbNewLine & RangetoHTML(rng)
                      .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 RangetoHTML(rng As Range)
  ' coded 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
  

  回复于 2024-05-13T18:19:17+08:00
• 0

  我使用了评论中提到的answer中的代码并对其进行了修改 . 创建一个类并将其命名为AppInfo . Here你发现如何做到这一点

  Option Explicit
  
  Public app As String
  Public version As String
  

  然后将以下代码放入模块中 . 假设数据位于活动工作表中，从A1开始， Headers 为Email，Application和Version .

  Option Explicit
  
  Sub Consolidate()
  
  #If Early Then
      Dim emailInformation As New Scripting.Dictionary
  #Else
      Dim emailInformation As Object
      Set emailInformation = CreateObject("Scripting.Dictionary")
  #End If
  
      GetEmailInformation emailInformation
      SendInfoEmail emailInformation
  End Sub
  
  
  Sub GetEmailInformation(emailInformation As Object)
  
  Dim rg As Range
  Dim sngRow As Range
  
  Dim emailAddress As String
  Dim myAppInfo As AppInfo
  Dim AppInfos As Collection
  
  Set rg = Range("A1").CurrentRegion    ' Assuming the list starts in A1 and DOES NOT contain empty row
  Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1)    ' Cut the headings
  
      For Each sngRow In rg.Rows
  
          emailAddress = sngRow.Cells(1, 1)
  
          Set myAppInfo = New AppInfo
          With myAppInfo
              .app = sngRow.Cells(1, 2)
              .version = sngRow.Cells(1, 3)
          End With
  
          If emailInformation.Exists(emailAddress) Then
              emailInformation.item(emailAddress).Add myAppInfo
          Else
              Set AppInfos = New Collection
              AppInfos.Add myAppInfo
              emailInformation.Add emailAddress, AppInfos
          End If
  
      Next
  
  End Sub
  Sub SendInfoEmail(emailInformation As Object)
  
  Dim sBody As String
  Dim sBodyStart As String
  Dim sBodyInfo As String
  Dim sBodyEnd As String
  Dim emailAdress As Variant
  Dim colLines As Collection
  Dim line As Variant
  
      sBodyStart = "Hi, please find your account permissions below:" & vbCrLf
  
  
      For Each emailAdress In emailInformation
          Set colLines = emailInformation(emailAdress)
          sBodyInfo = ""
          For Each line In colLines
              sBodyInfo = sBodyInfo & _
                           "Application: " & line.app & vbTab & "Version:" & line.version & vbCrLf
          Next
          sBodyEnd = "Best Regards" & vbCrLf & _
                     "Team"
  
          sBody = sBodyStart & sBodyInfo & sBodyEnd
          SendEmail emailAdress, "Permissions", sBody
      Next
  
  
  End Sub
  
  Sub SendEmail(ByVal sTo As String _
                , ByVal sSubject As String _
                  , ByVal sBody As String _
                    , Optional ByRef coll As Collection)
  
  
      #If Early Then
          Dim ol As Outlook.Application
          Dim outMail As Outlook.MailItem
          Set ol = New Outlook.Application
      #Else
          Dim ol As Object
          Dim outMail As Object
          Set ol = CreateObject("Outlook.Application")
      #End If
  
      Set outMail = ol.CreateItem(0)
  
      With outMail
          .To = sTo
          .Subject = sSubject
          .Body = sBody
          If Not (coll Is Nothing) Then
              Dim item As Variant
              For Each item In coll
                  .Attachments.Add item
              Next
          End If
  
          .Display
          '.Send
      End With
  
      Set outMail = Nothing
  
  End Sub
  

  回复于 2024-05-13T18:19:17+08:00
• 0

  在我看来，最简单的方法是将表格格式化为Excel中的表格（这将启用搜索和排序） . 然后你可以做一些像

  email = "test1@test.com"
  Set ws = ThisWorkbook.Worksheets("Sheet1")
  Set tbl = ws.ListObjects("Table1")
  tbl.Range.AutoFilter Field:=1, Criteria1:=email
  Set data = tbl.DataBodyRange
  If (data.Rows.Count = 0) Then Exit Sub
  

  如果执行使它超过了检查（data.Rows.Count> 0），那么您可以使用HTML发送邮件：

  Set app = CreateObject("Outlook.Application")
  Set mail = OutApp.CreateItem(0)
  bodyText = "<BODY style=font-size:11pt;font-family:Calibri>" & _
              " Hi, please find your account permissions below: <br> </BODY> "
  With mail
      .To = email
      .Subject = "Email title here."
      .HTMLBody = bodyText & "<p>" & RangeToHTML(data)
      .Importance = 1 ' normal
      .Display
  End With
  

  这需要以下辅助函数：

  Function RangeToHTML(rng As Range) As String
  
  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.Offset(1).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=")
  
      tempWB.Close savechanges:=False
      Kill tempFile
  
      Set ts = Nothing
      Set fso = Nothing
      Set tempWB = Nothing
  
  End Function
  

  您可以根据需要进行修改 .

  回复于 2024-05-13T18:19:17+08:00