因此，我建立了一个电子邮件系统，在其中将电子邮件发送给拥有特定项目的人，这些人的到期日即将到来。我的Excel工作表上至少有1,000个项目，每个项目都有一个特定的所有者。但是，所有者使用ID标记。该ID指的是另一张名为“ Permissions”的工作表中的电子邮件地址。我的电子邮件功能有效，但是我的接收方遇到了麻烦。我无法将包含项目的工作表上的ID与另一工作表中的电子邮件地址匹配。我对VBA还是很陌生，所以请原谅我的代码。我仍在学习。谢谢！
工作表名称“注册”是包含所有项目和截止日期的工作表。
代码 ：
Option Explicit
Sub TestEmailer()
Dim Row As Long
Dim lstRow As Long
Dim Message As Variant
Dim Frequency As String 'Cal Frequency
Dim DueDate As Date 'Due Date for Calibration
Dim vbCrLf As String 'For HTML formatting
Dim registerkeynumber As String 'Register Key Number
Dim class As Variant 'Class
Dim owner As String ' Owner
Dim status As String 'Status
Dim ws As Worksheet
Dim toList As Variant
Dim Ebody As String
Dim esubject As String
Dim Filter As String
Dim LQAC As String
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set ws = Sheets(1)
ws.Select
lstRow = WorksheetFunction.Max(2, ws.Cells(Rows.Count, Range("CalDueDate").Column).End(xlUp).Row)
For Row = 2 To lstRow
DueDate = CDate(Worksheets("Register").Cells(Row, Range("DueDate").Column).Value) 'DUE DATE
registerkeynumber = Worksheets("Register").Cells(Row, Range("RegisterKey").Column).Value
class = Worksheets("Register").Cells(Row, Range("Class").Column).Value
status = Worksheets("Register").Cells(Row, Range("Status").Column).Value
LQAC = Worksheets("Register").Cells(Row, Range("LQAC").Column).Value
Filter = Worksheets("Permissions").Cells(Row, Worksheets("Permissions").Range("MailFilter").Column).Value
If DueDate - Date <= 7 And class > 1 And status = "In Service" And DueDate <> "12:00:00 AM" Then
vbCrLf = "<br><br>"
'THIS IS WHERE I AM NOT SURE IF I AM REFERENCING CORRECTLY. I AM NOT SURE HOW TO REFERENCE THE ID FROM THE 'REGISTER' AND MATCH IT WITH THE EMAIL ADDRESS IN THE 'PERMISSIONS' WORKSHEET. AS OF NOW I AM ONLY REFERENCING THE EMAIL ADDRESS BUT THEY ARE NOT MATCHING UP.
toList = Worksheets("Permissions").Cells(Row, Worksheets("Permissions").Range("Email").Column).Value 'RECEPIENT OF EMIAL
esubject = "TEXT " & Cells(Row, Range("Equipment").Column).Value & " is due in the month of " & Format(DueDate, "mmmm-yyyy")
Ebody = "<HTML><BODY>"
Ebody = Ebody & "Dear " & Cells(Row, Range("LQAC").Column).Value & vbCrLf
Ebody = Ebody & "</BODY></HTML>"
SendEmail Bdy:=Ebody, Subjct:=esubject, Two:=toList
End If
Next Row
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Function SendEmail(Bdy As Variant, Subjct As Variant, Optional Two As Variant = "Email@xxx", Optional ReplyTo As Variant = "Email@xxx", Optional Carbon As Variant = "Email@xxx", Optional Attch As Variant = "FilePath", Optional Review As Boolean = False)
Dim OutlookEM As Outlook.Application
Dim EMItem As MailItem
If Not EmailActive Then Exit Function
If Two = "Email@xxx" Then
MsgBox "There is no Address to send this Email"
Two = ""
Review = True
'Exit Function
End If
'Create Outlook object
Set OutlookEM = CreateObject("Outlook.Application")
'Create Mail Item
Set EMItem = OutlookEM.CreateItem(0)
With EMItem
.To = Two
.Subject = Subjct
.HTMLBody = Bdy
End With
If ReplyTo <> "Email@xxx" Then EMItem.ReplyRecipients.Add ReplyTo
If Attch <> "FilePath" Then EMItem.Attachments.Add Attch
If Carbon <> "Email@xxx" Then EMItem.CC = Carbon
If Review = True Then
EMItem.Display (True)
Else
EMItem.Display
' EMItem.Send
End If
End Function
我认为我能够理解这里的问题。您的代码似乎没有使用任何vlookup公式或匹配公式来查找电子邮件。除非它们位于不同工作表之间的同一行中，否则您将需要找到该值。
VBA可以使用您通常在Excel中使用的功能。
如果您在下面的代码中加上正确的范围和列号，那么您应该能够根据ID找到正确的电子邮件地址。
' instead of 1 below, use the column for the id to look up
lookupValue = Worksheets("Register").Cells(Row, 1).Value
' range of the ids and emails in the permissions table - edit whatever the range should be
Rng = Worksheets("Permissions").Range("A1:B100")
' column to look up - number of columns between the id and email in the permissions tab
col = 2
' whether you want excel to try to find like match for the lookup value
' pretty much never have this be true if you want to have confidence in the result
likeMatch = False
emailAddress = WorksheetFunction.VLookup(lookupValue, Rng, col, likeMatch)
本文收集自互联网，转载请注明来源。
如有侵权，请联系[email protected] 删除。
我来说两句