0
그래서 기한이 오는 특정 항목을 소유 한 사람에게 이메일이 발송되는 이메일 시스템을 설정했습니다. 내 엑셀 시트에는 최소한 1,000 개의 항목이 있으며 각 항목에는 특정 소유자가 있습니다. 그러나 소유자는 ID를 사용하여 레이블이 지정됩니다. ID는 '사용 권한'이라는 다른 시트의 이메일 주소를 나타냅니다. 이메일 기능이 작동하지만 내 수신자에게 문제가 있습니다. 항목이있는 시트의 ID와 다른 시트의 이메일 주소를 일치시킬 수 없습니다. 나는 VBA에 상당히 익숙하므로 내 코드를 용서해주십시오. 나는 아직도 배우고있다. 고맙습니다!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 protected]", Optional ReplyTo As Variant = "[email protected]", Optional Carbon As Variant = "[email protected]", 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 protected]" 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 protected]" Then EMItem.ReplyRecipients.Add ReplyTo
If Attch <> "FilePath" Then EMItem.Attachments.Add Attch
If Carbon <> "[email protected]" Then EMItem.CC = Carbon
If Review = True Then
EMItem.Display (True)
Else
EMItem.Display
' EMItem.Send
End If
End Function