英文:
Send an email with content from different rows
问题
我有以下的VBA代码来发送带附件的邮件。
-
此代码的功能:生成并发送带附件的邮件,其信息来自Excel表中不同行的数据。
-
我希望代码实现的功能:识别来自同一账户的交易,将它们包括在同一封邮件中。这些信息在表格的B列中。
-
我希望改进此代码的方式:
-
我想要检查B列中所有单元格的数值,看是否有来自同一账户的交易,将它们包括在同一封邮件中,而不是分开发送。
-
我认为需要对代码的以下部分进行修改:
- 如果一封邮件中有多笔交易,交易摘要部分应相应重复。
- 如果一封邮件中有多笔交易,附件部分也应相应修改。附件部分需要相应修改。
-
一些重要的列:
- B:账户号码
- O:附件文件名
完整代码:(代码部分不进行翻译,仅返回注释部分的中文翻译)
英文:
I have the below VBA code to send emails with attachment.
-
What this code does: Generates and sends emails with attachment, whose information is from separate rows in the Excel table.
-
What I want the code to do: Recognise transactions from the same account to include in one email. This information is in column B of the table.
-
How I want this code to be improved:
-
I want to check all cell values in column B to see if there are any transactions coming from the same account to include them in the same email instead of sending them separately.
-
I think the changes must be made to these parts of the code:
- If there is more than one transaction in one email, the transaction summary part should repeat correspondingly.
- If there is more than one transaction in one email, there should also be more than one attachment. The attachment part would need to be modified accordingly.
-
Some important columns:
-
B: Account number
-
O: Attachment file name
The full code:
Sub SendEmail_Dispute()
' email processing
For i = 2 To Sheet2.Range("A" & Rows.Count).End(xlUp).Row
Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)
EmailItem.To = "abc@gmail.com"
EmailItem.Subject = "#" & Sheet2.Range("B" & i).Value & " - " & Sheet2.Range("M" & i).Value & ": " & Sheet2.Range("S" & i).Value
'[Transaction Summary Part] (starting at "------Transaction Summary-------")
EmailItem.HTMLBody = "Dear our valued customer, " & "<br>" & "<br>" & "We have registered a suspicious transaction from your account with number: " & "<b>" & Sheet2.Range("G" & i).Value & " - " & Sheet2.Range("H" & i).Value & "</b>" & ". The information is as follows: " & "<br>" & "<br>" & _
"------Transaction Summary-------" & "<br>" & "<br>" & _
"<table>" & _
"<table border='1' cellspacing='0' cellpadding=4'>" & _
"<tr><td><b> Transaction ID: </b></td><td>" & Sheet2.Range("C" & i).Value & "</td><td>" & Sheet2.Range("M" & i).Value & "</td></tr>" & _
"<tr><td><b> Transaction Amount: </b></td><td>" & Sheet2.Range("K" & i).Value & "</td><td>" & Sheet2.Range("T" & i).Value & " " & Sheet2.Range("W" & i).Value & "</td></tr>" & _
"<tr><td><b> Transaction Date: </b></td><td>" & Sheet2.Range("J" & i).Value & "</td><td>" & Sheet2.Range("U" & i).Value & "</td></tr>" & _
"</table>" & _
"<br>" & "<br>" & _
"Thank you" & "<br>" & "Best regards,"
'[Attachment Part]
'Source = ThisWorkbook.FullName
'---------Attachment
Dim fso As Scripting.FileSystemObject
Set fso = New FileSystemObject
Dim file As Scripting.file
Dim folder As Scripting.folder
Set folder = fso.GetFolder("C:\Users\main\Desktop\sus trx")
'Source = "C:\test"
For Each file In folder.Files
If Sheet2.Range("O" & i).Value = fso.GetBaseName(file.Name) Then
EmailItem.Attachments.Add file.Path
Exit For
End If
Next file
EmailItem.Send
Next i
End Sub
答案1
得分: 0
Here is the translated code:
尝试
Sub SendEmails()
Dim Applications As Object
Dim Applications_Item As Object
Dim Blist As Range
Dim bAcct As Range, xcell As Range, HtmlContent, firstAddress
Dim Key As Variant
Dim lastRow As Long
Dim dict
Dim attPath As String
Dim subjectMS, bodyGS
Set Applications = CreateObject("Outlook.Application")
lastRow = Sheet2.Cells(Rows.Count, "B").End(xlUp).Row
Set Blist = Sheet2.Range("B2:B" & lastRow)
Set dict = CreateObject("Scripting.Dictionary")
For Each xcell In Blist
If Not dict.Exists(CStr(xcell.Value)) Then
dict.Add CStr(xcell.Value), 1 '将帐号号码转换为字符串以用于字典
End If
Next xcell
For Each Key In dict.Keys
Set bAcct = Blist.Find(Key, LookIn:=xlValues)
If Not bAcct Is Nothing Then
Set Applications_Item = Applications.CreateItem(0)
firstAddress = bAcct.Address
Do
HtmlContent = HtmlContent & "<table>" & _
"<table border='1' cellspacing='0' cellpadding='4'>" & _
"<tr><td><b>交易ID:</b></td><td>" & Sheet2.Range("C" & bAcct.Row).Value & _
"</td><td>" & Sheet2.Range("M" & bAcct.Row).Value & "</td></tr>" & _
"<tr><td><b>交易金额:</b></td><td>" & Sheet2.Range("K" & bAcct.Row).Value & "</td><td>" & _
Sheet2.Range("T" & bAcct.Row).Value & " " & Sheet2.Range("W" & bAcct.Row).Value & "</td></tr>" & _
"<tr><td><b>交易日期:</b></td><td>" & Sheet2.Range("J" & bAcct.Row).Value & "</td><td>" & _
Sheet2.Range("U" & bAcct.Row).Value & "</td></tr>" & _
"</table>" & "<br>"
'附件
attPath = "C:\Users\main\Desktop\sus trx\"
Applications_Item.Attachments.Add attPath & Sheet2.Range("O" & bAcct.Row).Value
' 将列M-S的值附加到主题和列G-S的值附加到正文
subjectMS = subjectMS & ", " & Sheet2.Range("M" & bAcct.Row).Value & ":" & Sheet2.Range("S" & bAcct.Row).Value
bodyGS = bodyGS & ", " & Sheet2.Range("G" & bAcct.Row).Value & " - " & Sheet2.Range("H" & bAcct.Row).Value
Set bAcct = Blist.FindNext(bAcct)
Loop While Not bAcct Is Nothing And bAcct.Address <> firstAddress
End If
With Applications_Item
.To = "abc@gmail.com"
'.CC
.Subject = "#" & Sheet2.Range("B" & bAcct.Row).Value & " - " & Mid(subjectMS, 2)
.HTMLBody = "亲爱的尊贵客户," & "<br>" & "<br>" & "我们已经登记了您帐号上的可疑交易: " & _
"<b>" & Mid(bodyGS, 2) & "</b>" & _
". 信息如下: " & "<br>" & "<br>" & "------交易摘要-------" & "<br>" & "<br>" & _
HtmlContent & "<br>" & "<br>" & "谢谢您" & "<br>" & "此致敬礼,"
.Display '测试后注释掉并使用 .send
'.Send
End With
HtmlContent = ""
subjectMS = ""
bodyGS = ""
Next Key
Set Applications = Nothing
Set Applications_Item = Nothing
Set dict = Nothing
End Sub
I've translated the code as requested.
英文:
try
Sub SendEmails()
Dim Applications As Object
Dim Applications_Item As Object
Dim Blist As Range
Dim bAcct As Range, xcell As Range, HtmlContent, firstAddress
Dim Key As Variant
Dim lastRow As Long
Dim dict
Dim attPath As String
Dim subjectMS, bodyGS
Set Applications = CreateObject("Outlook.Application")
lastRow = Sheet2.Cells(Rows.Count, "B").End(xlUp).Row
Set Blist = Sheet2.Range("B2:B" & lastRow)
Set dict = CreateObject("Scripting.Dictionary")
For Each xcell In Blist
If Not dict.Exists(CStr(xcell.Value)) Then
dict.Add CStr(xcell.Value), 1 'CStr convert to account number to string for the dictionary
End If
Next xcell
For Each Key In dict.Keys
Set bAcct = Blist.Find(Key, LookIn:=xlValues)
If Not bAcct Is Nothing Then
Set Applications_Item = Applications.CreateItem(0)
firstAddress = bAcct.Address
Do
HtmlContent = HtmlContent & "<table>" & _
"<table border='1' cellspacing='0' cellpadding=4'>" & _
"<tr><td><b> Transaction ID: </b></td><td>" & Sheet2.Range("C" & bAcct.Row).Value & _
"</td><td>" & Sheet2.Range("M" & bAcct.Row).Value & "</td></tr>" & _
"<tr><td><b> Transaction Amount: </b></td><td>" & Sheet2.Range("K" & bAcct.Row).Value & "</td><td>" & _
Sheet2.Range("T" & bAcct.Row).Value & " " & Sheet2.Range("W" & bAcct.Row).Value & "</td></tr>" & _
"<tr><td><b> Transaction Date: </b></td><td>" & Sheet2.Range("J" & bAcct.Row).Value & "</td><td>" & _
Sheet2.Range("U" & bAcct.Row).Value & "</td></tr>" & _
"</table>" & "<br> "
'Attachment
attPath = "C:\Users\main\Desktop\sus trx\"
Applications_Item.Attachments.Add attPath & Sheet2.Range("O" & bAcct.Row).Value
' append values of columns M-S to subject and G-S to body
subjectMS = subjectMS & ", " & Sheet2.Range("M" & bAcct.Row).Value & ":" & Sheet2.Range("S" & bAcct.Row).Value
bodyGS = bodyGS & ", " & Sheet2.Range("G" & bAcct.Row).Value & " - " & Sheet2.Range("H" & bAcct.Row).Value
Set bAcct = Blist.FindNext(bAcct)
Loop While Not bAcct Is Nothing And bAcct.Address <> firstAddress
End If
With Applications_Item
.To = "abc@gmail.com"
'.CC
.Subject = "#" & Sheet2.Range("B" & bAcct.Row).Value & " - " & Mid(subjectMS, 2)
.HTMLBody = "Dear our valued customer, " & "<br>" & "<br>" & "We have registered a suspicious transaction from your account with number(s): " & _
"<b>" & Mid(bodyGS, 2) & "</b>" & _
". The information is as follows: " & "<br>" & "<br>" & "------Transaction Summary-------" & "<br>" & "<br>" & _
HtmlContent & "<br>" & "<br>" & "Thank you" & "<br>" & "Best regards,"
.Display 'comment out and use .send after testing
'.Send
End With
HtmlContent = ""
subjectMS = ""
bodyGS = ""
Next Key
Set Applications = Nothing
Set Applications_Item = Nothing
Set dict = Nothing
End Sub
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论