我想用 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
uj5u.com熱心網友回復：
請測驗下一個更新的代碼。它使用字典來提取唯一的郵件帳戶和所有必要的資料以按照您的需要行事。代碼后面有Stop一行，.Display讓您查看新郵件在其視窗中的外觀。執行相應行注釋中所寫的內容。否則，它將創建許多新的郵件視窗，因為 Q:Q 中有許多 UNIQUE 記錄：
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
uj5u.com熱心網友回復：
首先，您需要制作匯總表，然后從該表發送。在此代碼中，它添加了新作業表，在其中制作匯總表并從該表發送
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/513813.html
上一篇：來自檔案夾中最新檔案的VBA（“運行時錯誤1004”）
下一篇：在資料中查找列組