所以我有一个按案例分类的excel表格,分配给电子邮件。每个案例都分配给一封电子邮件,每封电子邮件负责一个以上的案例。电子邮件不按顺序排列,它们分散在整个列中。 我想创建一个自动发送的电子邮件,每周一发送提醒(我还没弄清楚如何)提交案例。问题是我想每人发送一封电子邮件,重新组合分配给他们的所有案件。 (当案件关闭时,它会从表格中消失,因此无需担心这一点。)
以下是我已写的内容:
Sub datesexcelvba()
Dim myApp As Outlook.Application, mymail As Outlook.MailItem
Dim mydate1 As Date
Dim mydate2 As Long
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim engineer As Range
Dim x As Long
lastrow = Sheets("Messages english").Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lastrow
mydate1 = Cells(x, 3).Value
mydate2 = mydate1
Cells(x, 7) = mydate2
datetoday1 = Date
datetoday2 = datetoday1
Cells(x, 9).Value = datetoday2
Set daysLeft = mydate2 - datetoday2
Function itsokay()
If daysLeft <= 14 And daysLeft >= 8 Then
Set myApp = New Outlook.Application
Set mymail = myApp.CreateItem(olMailItem)
mymail.To = Cells(x, 2).Value
'.send
With mymail
.Subject = (xx)
.Body = (Message) (content of a cell) (message)...etc
.Display
End With
Cells(x, 10) = Date
Cells(x, 10).Interior.ColorIndex = 3
Cells(x, 10).Font.ColorIndex = 2
Cells(x, 10).Font.Bold = True
End If
End Function
Function comeon()
If daysLeft <= 7 And daysLeft >= 4 Then
Set myApp = New Outlook.Application
Set mymail = myApp.CreateItem(olMailItem)
mymail.To = Cells(x, 2).Value
'.send
With mymail
.Subject = (xx)
.Body = (Message) (content of a cell) (message)...etc
.Display
End With
Cells(x, 11) = Date
Cells(x, 11).Interior.ColorIndex = 3
Cells(x, 11).Font.ColorIndex = 2
Cells(x, 11).Font.Bold = True
End If
End Function
Function late()
If daysLeft < 4 Then
Set myApp = New Outlook.Application
Set mymail = myApp.CreateItem(olMailItem)
mymail.To = Cells(x, 2).Value
'.send
With mymail
.Subject = (xx)
.Body = (Message) (content of a cell) (message)...etc
.Display
End With
Cells(x, 12) = Date
Cells(x, 12).Interior.ColorIndex = 3
Cells(x, 12).Font.ColorIndex = 2
Cells(x, 12).Font.Bold = True
End If
End Function
engineer = Cell(x, 6).Value
If engineer = "PLM" Then
// here i should write the code that sends each email(functions created above to the engineer)
Next
Set myApp = Nothing
Set mymail = Nothing
End Function
谢谢!! 最后一个问题:如何在.Body函数中的文本之间显示信息?This is what my excel sheet looks like 只有在设计状态时才会发送电子邮件,并且电子邮件的文本大致如下所示 亲爱的(F2), 这提醒你,你的dcp(A2)(b2)应该是(G2), 你的Dcp(a3)(b3)到期了(g3) error 13 screenshot
答案 0 :(得分:1)
这是一种通用方法,因为我们没有您的实际数据。
据我了解,您正在创建案例数据的循环作为开始。这不是恕我直言的好方法;如果您在电子邮件数据中设置第一个循环,那么在案例数据中设置第二个循环将更容易处理案例。第二个循环将每个case添加到一个字符串,之后将用作邮件正文。条件是案件的电子邮件是否等于您在外面循环的电子邮件。
在为一封电子邮件构建正文后(如果正文不为空),您将调用电子邮件发送程序。
我希望这有帮助,如果没有尝试从您的数据中提供一些样本,那么我或之后可能会创建一个功能代码。
编辑:由于您没有单独的电子邮件地址列表,您应首先创建一个电子邮件数组,然后将该列表用作外部循环。我没有机会尝试但是下面的代码应该以某种方式帮助你开始循环,电子邮件bodt构造等:
Sub datesexcelvba()
' create a dictionary object of unique e-mails
Dim d As Object, c As Range, k, tmp As String
Set d = CreateObject("scripting.dictionary")
For Each c In Range("H:H").Cells
tmp = Trim(c.Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next c
For Each k In d.keys
' This is the outer loop of e-mails, the body shoul be constructed here and the e-mail should be sent at the end.
' I am keeping your inner loop since I assume that there is no problem with it
lastrow = Sheets("Messages english").Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lastrow
If Cells(x, 4).Value = "Design" And Cells(x, 8).Value = k Then
myMail.Body = "Dcp No:" & Cells(x, 1).Value
myMail.Body = myMail.Body & " | Desc:" & Cells(x, 2).Value
myMail.Body = myMail.Body & " | Due Date:" & Cells(x, 7).Value
myMail.Body = myMail.Body & Chr(13) 'line feed
End If
Next x
If myEmail.Body <> "" Then Send_Mail k, "Task is due!", myMail.Body
Next k
End Sub
Function Send_Mail(ByVal email_recipient As String, ByVal email_subject, ByVal email_body As String)
Dim myApp As Outlook.Application
Set myApp = New Outlook.Application
Dim myMail As Outlook.MailItem
Set myMail = myApp.createItem(olMailItem)
With myMail
.To = email_recipient
.Subject = email_subject
.Body = email_body
'.Display
End With
Set myMail = Nothing
Set myApp = Nothing
End Function
答案 1 :(得分:0)
好的,这是一个可能适合您的解决方案的拼凑版本。我注意到你错过了一个循环的想法,所以我希望你至少可以使用它来使它做你正在寻找的东西!
Sub DCP_Emails()
Dim mydate1 As Date
Dim mydate2 As Long
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim daysLeft As Integer
Dim lastRow As Integer
lastRow = Sheets("Messages english").Cells(Rows.Count, 1).End(xlUp).Row
Dim x As Integer
For x = 2 To lastRow
mydate1 = Cells(x, "C").value
mydate2 = mydate1
Cells(x, "G") = mydate2
datetoday1 = Date
datetoday2 = datetoday1
Cells(x, "I").value = datetoday2
daysLeft = mydate2 - datetoday2
If LCase$(Cells(x, "D").Value2) = "design" Then
If daysLeft <= 14 And daysLeft >= 8 Then
Send_Mail Cells(x, "H").Value2, "DCP Reminder - Priority: Low", _
"Dear " & Cells(x, "F") & ", " & Chr(10) & Chr(10) & _
"This is a reminder that your DCP " & Cells(x, "A") & " " & Cells(x, "B") & " is due on " & Cells(x, "G")
ElseIf daysLeft <= 7 And daysLeft >= 4 Then
Send_Mail Cells(x, "H").Value2, "DCP Reminder - Priority: Medium", _
"Dear " & Cells(x, "F") & ", " & Chr(10) & Chr(10) & _
"This is a reminder that your DCP " & Cells(x, "A") & " " & Cells(x, "B") & " is due on " & Cells(x, "G")
Else
Send_Mail Cells(x, "H").Value2, "DCP Reminder - Priority: High", _
"Dear " & Cells(x, "F") & ", " & Chr(10) & Chr(10) & _
"This is a reminder that your DCP " & Cells(x, "A") & " " & Cells(x, "B") & " is due on " & Cells(x, "G")
End If
With Cells(x, "J")
.Value2 = Date
.Interior.ColorIndex = 3
.Font.ColorIndex = 2
.Font.Bold = True
End With
End If
Next x
Set myApp = Nothing
End Sub
Function Send_Mail(ByVal email_recipient As String, ByVal email_subject, ByVal email_body As String)
Dim myApp As Outlook.Application
Set myApp = New Outlook.Application
Dim myMail As Outlook.MailItem
Set myMail = myApp.createItem(olMailItem)
With myMail
.To = email_recipient
.Subject = email_subject
.Body = email_body
'.Display
End With
Set myMail = Nothing
Set myApp = Nothing
End Function
答案 2 :(得分:0)
@hakan
Sub DCP_Emails()
Dim mydate1 As Date
Dim mydate2 As Long
Dim datetoday1 As Date
Dim datetoday2 As Long
Dim daysLeft As Long
Dim lastRow As Long
Dim d As Object, c As Range, k, tmp As String
Set d = CreateObject("scripting.dictionary")
For Each c In Range("H:H").Cells
If c.Value <> "N/A" Then
tmp = Trim(c.Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next c
For Each k In d.keys
lastRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Dim x As Long
For x = 2 To lastRow
If Cells(x, 7).Value <> " " Then
mydate1 = Cells(x, 7).Value
mydate2 = mydate1
Cells(x, "J") = mydate2
datetoday1 = Date
datetoday2 = datetoday1
Cells(x, "K").Value = datetoday2
daysLeft = mydate2 - datetoday2
If LCase$(Cells(x, "D").Value2) = "design" And Cells(x, 8).Value = k Then
If daysLeft <= 14 And daysLeft >= 8 Then
Send_Mail k.Value2, "DCP Reminder - Priority: Low", _
"Dear " & Cells(x, "F") & ", " & Chr(10) & Chr(10) & _
"This is a reminder that your DCP " & Cells(x, "A") & " " & Cells(x, "B") & " is due on " & Cells(x, "G")
End If
With Cells(x, "L")
.Value2 = Date
.Interior.ColorIndex = 3
.Font.ColorIndex = 2
.Font.Bold = True
End With
End If
End If
Next x
Next k
Set myApp = Nothing
End Sub
Function Send_Mail(ByVal email_recipient As String, ByVal email_subject, ByVal email_body As String)
Dim myApp As Object
Set myApp = CreateObject("Outlook.Application")
Dim myMail As Object
Set myMail = myApp.createItem(0)
With myMail
.To = email_recipient
.Subject = email_subject
.Body = email_body
.Send
'.Display
End With
Set myMail = Nothing
Set myApp = Nothing
End Function