为每个用户将Excel信息整合到一封电子邮件中
我的表格结构如下:为每个用户将Excel信息整合到一封电子邮件中,excel,vba,Excel,Vba,我的表格结构如下: Vendor Consultor CLIENT Date OS Status test@test.com Andrew NAME 1 25/12/2017 123456 Pend test@test.com Andrew NAME 2 31/12/2017 789123 Pend test134@test.com Joseph NAME 3 10/
Vendor Consultor CLIENT Date OS Status
test@test.com Andrew NAME 1 25/12/2017 123456 Pend
test@test.com Andrew NAME 2 31/12/2017 789123 Pend
test134@test.com Joseph NAME 3 10/12/2017 654321 Pend
我需要整合卖家“Andrew或Joseph”待处理的所有内容,并发送一封包含“OS”列表的电子邮件。
我正在使用以下代码,但未成功,因为它会为工作表的每一行打开一封新电子邮件:
Sub email()
Dim i As Long
Dim OutApp, OutMail As Object
Dim strto, strcc, strbcc, strsub, strbody As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For i = 1 To Range("C5536").End(xlUp).Row
Set OutMail = OutApp.CreateItem(0)
strto = Cells(i, 1)
strsub = "OS - PENDING"
strbody = "Hello," & vbCrLf & vbCrLf & _
"Please, check your pending OS's" & vbCrLf & vbCrLf & _
"Detalhes:" & vbCrLf & _
"Consultor:" & Cells(i, 3) & vbCrLf & _
"Date:" & Cells(i, 4) & vbCrLf & _
"OS:" & Cells(i, 5) & vbCrLf & vbCrLf & _
"Best Regards" & vbCrLf & _
"Team"
With OutMail
.To = strto
.Subject = strsub
.Body = strbody
.Display
End With
On Error Resume Next
Next
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
使用以下代码创建一个类行
Option Explicit
Private mClient As String
Private mDate As Date
Private mOS As String
Public Property Get Client() As String
Client = mClient
End Property
Public Property Let Client(ByVal bNewValue As String)
mClient = bNewValue
End Property
Public Property Get dDate() As Date
dDate = mDate
End Property
Public Property Let dDate(ByVal bNewValue As Date)
mDate = bNewValue
End Property
Public Property Get OS() As String
OS = mOS
End Property
Public Property Let OS(ByVal sNewValue As String)
mOS = sNewValue
End Property
然后将以下代码放入一个模块并运行Consolidate
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 vendorLine As cVendorLine
Dim vendorLines 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 vendorLine = New cVendorLine
With vendorLine
.Client = sngRow.Cells(1, 3)
.dDate = sngRow.Cells(1, 4)
.OS = sngRow.Cells(1, 5)
End With
If emailInformation.Exists(emailAddress) Then
emailInformation.item(emailAddress).Add vendorLine
Else
Set vendorLines = New Collection
vendorLines.Add vendorLine
emailInformation.Add emailAddress, vendorLines
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 = "Hello," & vbCrLf & vbCrLf & _
"Please, check your pending OS's" & vbCrLf & vbCrLf & _
"Detalhes:" & vbCrLf
For Each emailAdress In emailInformation
Set colLines = emailInformation(emailAdress)
sBodyInfo = ""
For Each line In colLines
sBodyInfo = sBodyInfo & _
"Consultor:" & line.Client & vbCrLf & _
"Date:" & line.dDate & vbCrLf & _
"OS:" & line.OS & vbCrLf
Next
sBodyEnd = "Best Regards" & vbCrLf & _
"Team"
sBody = sBodyStart & sBodyInfo & sBodyEnd
SendEmail emailAdress, "OS - PENDING", 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
你好@Storax!首先,谢谢你的帮助和时间!我照你说的做了,我得到了一个错误“编译错误”。这一行“Sub-GetEmailInformation(emailInformation As Scripting.Dictionary)”中显示了错误。很抱歉,我没有删除整个代码中的早期绑定。完成后,我相应地编辑了代码。您必须添加一个名为cVendorLine的新类,并将上面的代码放入该类中。下面是一个我仍然无法运行的示例,错误是“Sub-GetEmailInformation(emailInformation作为对象)”和Dim vendorLine作为CVendorLine。它工作得很好,谢谢!我唯一关心的是“操作系统”之间的空间。是否可以在中间添加一行?