如果一个值相同，VBA Excel 仅在一封电子邮件中发送所有信息

Question

我想用 VBA 发送一封电子邮件，将用户编号发送到电子邮件地址，但如果他有 2 个用户编号，他会在同一封邮件中发送 2 个用户编号。

我的 Excel 代码：

Private Sub CommandButton1_Click()

    Dim mail As Variant
    Dim ligne As Integer

    Set mail = CreateObject("Outlook.Application") 'create an outlook object

    For ligne = 1 To 5

        If Range("n" & ligne) = "OK" Then

            With mail.CreateItem(olMailItem) ' informs the program that we want to send a mail.
                .Subject = TEST
                .To = Range("q" & ligne)
                .CC = "[email protected]"
                .Body = "Hi number " & Range("I" & ligne) & " You are owner of users :" 'users
                .SendUsingAccount = "[email protected]"
                .Display 'display the mail before sending it if not place send to send
            End With
            
        End If
        
    Next ligne
    
End Sub

Answer 1

请测试下一个更新的代码。它使用字典来提取唯一的邮件帐户和所有必要的数据，以满足您的需要。该代码在

Stop

之后有一个

.Display

行，可让您查看新邮件在其窗口中的外观。执行相应行注释中所写的操作。否则，它将创建与 Q:Q:

中的唯一记录一样多的新邮件窗口

Sub sendMailCond()
 Dim sh As Worksheet, lastRQ As Long, arr, arrUs, i As Long
 Dim mail As Object, strUsers As String, dict As Object
 
 Set sh = ActiveSheet
 lastRQ = sh.Range("Q" & sh.rows.count).End(xlUp).row 'last row on Q:Q
 arr = sh.Range("A2:Q" & lastRQ).Value 'place the range in an array for faster processing
 
 'Place the necessary data in the dictionary:
 Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary
 For i = 1 To UBound(arr)
    If arr(i, 14) Like "OK" Then
         If Not dict.exists(arr(i, 17)) Then
                dict.Add arr(i, 17), arr(i, 9) & "|" & arr(i, 1)
         Else
               dict(arr(i, 17)) = dict(arr(i, 17)) & "::" & arr(i, 1)
         End If
         
    End If
 Next i
 
 Set mail = CreateObject("Outlook.Application") 'create an outlook object
 'extract the necessary data:
 For i = 0 To dict.count - 1
     arr = Split(dict.Items()(i), "|") 'split the item by "|" to extract value from I:I and a concatenation by "::" separator if more then one key exists
     arrUs = Split(arr(1), "::")

       If UBound(arrUs) > 0 Then
              strUsers = Join(arrUs, " / ")
       Else
              strUsers = arr(1)
       End If
      With mail.CreateItem(olMailItem) ' informs the program that we want to send a mail.
            .Subject = "Test"
            .To = dict.Keys()(i)
            .cc = "[email protected]"
            .body = "Hi number " & arr(0) & " You are owner of users : " & strUsers
            .SendUsingAccount = "[email protected]"
            .Display: Stop 'See the New mail in Outlook and check its contents
                           'press F5 to continue!
     End With
 Next i
End Sub

如果它按您想要的方式返回，您可以将以

Disply

开头的行替换为

.Send

。

已编辑：

新版本也从M:M中提取并放置在正文的末尾：

Sub sendMailCond2()
 Dim sh As Worksheet, lastRQ As Long, arr, arrUs, i As Long
 Dim mail As Object, strUsers As String, dict As Object
 
 Set sh = ActiveSheet
 lastRQ = sh.Range("Q" & sh.rows.count).End(xlUp).row
 arr = sh.Range("A2:Q" & lastRQ).Value
 
 'Place the necessary data in the dictionary:
 Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary
 For i = 1 To UBound(arr)
    If arr(i, 14) Like "OK" Then
         If Not dict.exists(arr(i, 17)) Then
                dict.Add arr(i, 17), arr(i, 9) & "|" & arr(i, 13) & "|" & arr(i, 1)
         Else
                dict(arr(i, 17)) = dict(arr(i, 17)) & "::" & arr(i, 1)
         End If
         
    End If
 Next i
 
 Set mail = CreateObject("Outlook.Application") 'create an outlook object
 'extract the necessary data:
 For i = 0 To dict.count - 1
     arr = Split(dict.Items()(i), "|")
     arrUs = Split(arr(2), "::")

       If UBound(arrUs) > 0 Then
              strUsers = Join(arrUs, " / ") & ". Your last connection was " & arr(1)
       Else
              strUsers = arr(2) & ". Your last connection was " & arr(1)
       End If
      With mail.CreateItem(olMailItem) ' informs the program that we want to send a mail.
            .Subject = "Test"
            .To = dict.Keys()(i)
            .cc = "[email protected]"
            .body = "Hi number " & arr(0) & " You are owner of users : " & strUsers
            .SendUsingAccount = "[email protected]"
            .Display: Stop 'See the New mail in Outlook and check its contents
                           'press F5 to continue!
     End With
 Next i
End Sub

Answer 2

首先您需要制作汇总表，然后从该表发送。在此代码中，它添加新工作表，在其中创建汇总表并从该表发送

Private Sub CommandButton1_Click()

 Dim mail As Variant, Owner As Variant, user As Variant
 Dim ligne As Integer, x As Integer, i As Integer, j As Integer, RowNum As Integer
 Dim ws As Worksheet, ws2 As Worksheet
 Dim found As Boolean
 
 Set ws = ActiveSheet
 Set ws2 = Sheets.Add
 ws2.Cells(1, "A") = "Value"
 ws2.Cells(1, "B") = "email"
 ws2.Cells(1, "C") = "Usernames"
 
 x = ws.Cells(1, "I").End(xlDown).Row 'get last row with data
 If x > 1 Then
     For i = 2 To x
      If ws.Range("n" & i) = "OK" Then
       Owner = ws.Cells(i, "I").Value
       user = ws.Cells(i, "G").Value
       mail = ws.Cells(i, "Q").Value
       RowNum = ws2.Cells(65536, 1).End(xlUp).Row 'get last row with summarized data, asuming that there will not be more than 65536 owners
       If RowNum = 1 Then
         ws2.Cells(2, 1) = Owner
         ws2.Cells(2, 2) = mail
         ws2.Cells(2, 3) = user
       Else
        found = False
        For j = 2 To RowNum 'check if there already is such owner
         If ws2.Cells(j, 1) = Owner Then
          found = True
          ws2.Cells(j, 3) = ws2.Cells(j, 3).Value & ", " & user 'adds new Username to existing, delimiting by comma and space
          Exit For
         End If
        Next j
        If found = False Then
         ws2.Cells(RowNum + 1, 1) = Owner
         ws2.Cells(RowNum + 1, 2) = mail
         ws2.Cells(RowNum + 1, 3) = user
        End If
       End If 'Rownum>1
      End If '=OK
     Next i
     RowNum = ws2.Cells(65536, 1).End(xlUp).Row 
     If RowNum > 1 Then ' if there is at least 1 OK user

 Set mail = CreateObject("Outlook.Application") 'create an outlook object

 For ligne = 2 To RowNum

     With mail.CreateItem(olMailItem) ' informs the program that we want to send a mail.
             .Subject = test
             .To = ws2.Range("b" & ligne)
             .CC = "[email protected]"
             .Body = "Hi number " & ws2.Range("A" & ligne) & " You are owner of users :" & ws2.Range("C" & ligne) 'users
             .SendUsingAccount = "[email protected]"
             .Display 'display the mail before sending it if not place send to send
         End With 
        End If
       Next ligne
      End If 'Rownum >1
     End If 'x>1
    End Sub