I want send a email with VBA where I send user number to email address but if he have 2 user number he send the 2 user number in the same mail.
My code with my 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
CodePudding user response：
Please, test the next updated code. It uses a dictionary to extract the unique mail accounts and all the necessary data to behave as you need. The code has a Stop line, after .Display to let you see how the new mail looks in its window. Do what is written in the respective line comment. Otherwise, it will create so many new mail window as many UNIQUE records are in 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
If it returns as you want, you can replace the line starting with Disply with .Send.
Edited:
The new version extracting from M:M, too and placing at the end of body:
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
CodePudding user response：
At first you need to make summarized table and then send from that table. In this code it adds new sheet, makes summarized table in it and sends from that table
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