如何使用 VBA 将文本引用到相应的电子邮件地址

Question

所以我建立了一个电子邮件系统，在这个系统中，电子邮件被发送给拥有特定项目的人，这些项目的截止日期即将到来。我的 excel sheet 上至少有 1,000 件物品，每件物品都有特定的所有者。但是，所有者使用 ID 进行标记。该 ID 指的是另一个 sheet 中名为 "Permissions" 的电子邮件地址。我的电子邮件功能有效，但我的收件人遇到问题。我无法将包含项目的 sheet 上的 ID 与另一个 sheet 中的电子邮件地址相匹配。我是 VBA 的新手，所以请原谅我的代码。我仍在学习。谢谢！

作品sheet名称"Register"是包含所有项目和截止日期的作品sheet。

代码：

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

Answer 1

我想我能够了解这里的问题所在。看起来您的代码没有使用任何 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)

如何使用 VBA 将文本引用到相应的电子邮件地址

How to reference Text to respective email address using VBA

excel

vba