Paste formatted Excel range into Outlook task - excel

I've been trying to create a sub that would take some information from an Excel selection and create a new task on Outlook. The body of the task should feature the comment from the first cell (which it already does) but before all that I want to paste the range as it looks in Excel, then the comment, and then again, the range.
Here's my code:
Sub CreateReminder()
Dim olApp As Object
Dim olRem As Object
Dim myRange As Range
Dim contact As String
Dim company As String
Dim city As String
Dim state As String
Dim cmt As comment
Dim comment As String
Dim strdate As Date
Dim remdate As Date
Set olApp = CreateObject("Outlook.Application")
Set olRem = olApp.CreateItem(3)
Set myRange = Selection
If ActiveCell.comment Is Nothing Then
Exit Sub
Else
Set cmt = ActiveCell.comment
End If
company = myRange.Columns(1).Text
contact = myRange.Columns(2).Text
If InStr(contact, "/") <> 0 Then
contact = Left(contact, InStr(contact, "/") - 1)
End If
city = myRange.Columns(7).Text
state = myRange.Columns(8).Text
myRange.Copy
comment = cmt.Text
strdate = Date
remdate = Format(Now)
rangeaddress = myRange.Address
wrksheetname = ActiveSheet.Name
With olRem
.Subject = "Call " & contact & " - " & company & " - " & city & ", " & state
.display
SendKeys "{TAB 9}"
SendKeys "^{v}"
.body = Chr(10) & comment & Chr(10)
'.startdate = strdate
'.remindertime = remdate
'.reminderset = True
'.showcategoriesdialog
End With
Set olApp = Nothing
Set olRem = Nothing
End Sub
As you can see, I am able to paste using a SendKeys method, but it is sort of a hack, and not... sophisticated. I'm sure there's another way of doing it, any ideas?
I found code for pasting as HTML to an email, but as I understand, the Mail item allows for HTML, but not the Task item.

Outlook uses Word as an email editor. You can use the Word object model for making manipulatins on the message body. The WordEditor property of the Inspector class returns an instance of the Document class (from the Word object model) which represents the body. You can read more about that way and all possible ways in the Chapter 17: Working with Item Bodies.
That way you can use the Copy method of the Range class to copy the range to the Clipboard. Then you can use the Paste method from the Word object model to paste data into the document which represents the message body.

Related

Convert Outlook Contact Group early binding Excel VBA to late binding

I am trying to insert a list of email addresses from Excel into a contact group in Outlook.
I found Excel VBA code online. It uses early binding. It is not an option to force the user to go into Tools-> References -> Outlook, when they open the file.
I need to transform the code from early to late binding.
Questions:
I understand that I need to change Outlook.Application to
CreateObject('Outlook.Application') and that I can access
olFolderContacts with the number 10 instead. See code below.
I can't figure out how to access the remaining items such as
CreateItem(olDistributionListItem).
Sub CreateContactGroupfromExcel()
Dim objContactsFolder As Outlook.Folder
Dim objContact As Outlook.ContactItem
Dim objContactGroup As Outlook.DistListItem
Dim objNameCell As Excel.Range
Dim objEmailCell As Excel.Range
Dim strName As String
Dim strEmail As String
Dim objTempMail As Outlook.MailItem
Dim objRecipients As Outlook.Recipients
Set objContactsFolder = Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
Set objContactGroup = Outlook.Application.CreateItem(olDistributionListItem)
'You can change the contact group name
objContactGroup.DLName = "PlaceHolder_VBA"
i = 0
Do While Range("vba_email_outlook").Offset(i, 0).Value <> "":
strName = Range("vba_name_outlook").Offset(i, 0).Value
strEmail = Range("vba_email_outlook").Offset(i, 0).Value
Set objContact = objContactsFolder.Items.Find("[FullName] = '" & strName & "'")
'If there is no such a contact, create it.
If objContact Is Nothing Then
Set objContact = Outlook.Application.CreateItem(olContactItem)
With objContact
.FullName = strName
.Email1Address = strEmail
.Save
End With
End If
'Add the contacts to the new contact group
Set objTempMail = Outlook.CreateItem(olMailItem)
objTempMail.Recipients.Add (strName)
Set objRecipients = objTempMail.Recipients
objContactGroup.AddMembers objRecipients
i = i + 1
Loop
'Use "objContactGroup.Save" to straightly save it
objContactGroup.Display
objTempMail.Close olDiscard
End Sub
Declare object variables as generic Object
Dim objContactsFolder As Object
Determine number values of constants. With early binding, these values can be seen when hovering over constant or in VBA immediate window: ?olMailItem. Then reference number in place of constant or leave constants referenced as they are and declare them as constants with Const statements. Const olMailItem = 0
olFolderContacts = 10
olMailItem = 0
olDistributionListItem = 7
I am not an expert but this code allows you to add the reference when you run the VBA script, but it will mean that if it errors out the code quits running you will not be able to debug.
On Error Resume Next ''' If reference already exist this would cause an error
Application.VBE.ActiveVBProject.References.AddFromFile ("C:\Program Files (x86)\Microsoft Office\Office16\MSOUTL.OLB") ''' Might have to change file path
On Error GoTo 0

Find Outlook Email with keywords in Subject & attachment using Excel VBA

I am trying to search Outlook for the most recent email with "Blue Recruit Req Data" in the Subject line.
There will be additional words in the subject line.
When an email is found I need to verify that it has an attachment.
I want to store the subject & the received date in variables and compare them to previous subject & date stored in the Excel file running the macro.
If the subject lines don't match & the date of the email is after the date last stored in the Excel file, then I want to save that attachment in a folder.
It is not finding emails that contain "Blue Recruit Req Data" in the subject.
Sub CheckEmail_BlueRecruit()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim olAp As Object, olns As Object, olInb As Object
Dim olItm As Object, olAtch As Object, olMail As Object
'Outlook Variables for email
Dim sSubj As String, dtRecvd As String
Dim oldSubj As String, olddtRecvd As String
Sheets("Job Mapping").Visible = True
Sheets("CC Mapping").Visible = True
Sheets("Site Mapping").Visible = True
Sheets("Historical Blue Recruit Data").Visible = True
Sheets("Historical HRT Data").Visible = False
Sheets("Combined Attrition Data").Visible = True
Sheets.Add Before:=Sheets(1)
'Designate ECP Facilities Model file as FNAME
myPath = ThisWorkbook.Path
MainWorkbook = ThisWorkbook.Name
Range("A1").Select
ActiveCell.FormulaR1C1 = myPath
'designate file path for Attrition Files
FacModPath = Cells(1, 1).Value
Sheets(1).Delete
'Get Outlook Instance
Set olAp = GetObject(, "Outlook.application")
Set olns = olAp.GetNamespace("MAPI")
Set olInb = olns.GetDefaultFolder(6)
Set olMail = olInb.Items.Restrict("[Subject] = ""*Blue Recruit Req Data*""")
'Chec if there are any matching emails
If Not (olMail Is Nothing) Then
For Each olItm In olMail
If myItem.Attachments.Count <> 0 Then
dtRecvd = olItm.ReceivedTime
sSubj = olItm.Subject
oldSubj = Sheets("CC Mapping").Range("M2").Value
olddtRecvd = Sheets("CC Mapping").Range("M3").Value
If sSubj = oldSubj Or dtRecvd <= olddtRecvd Then
MsgBox "No new Blue Recruit data files to load."
Exit Sub
Else
Range("M2").Select
ActiveCell.FormulaR1C1 = sSubj
Range("M3").Select
ActiveCell.FormulaR1C1 = dtRecvd
For Each myAttachment In myItem.Attachments
If InStr(myAttachment.DisplayName, ".xlsx") Then
I = I + 1
myAttachment.SaveAs Filename:=FacModPath & "\" & myAttachment.DisplayName
Exit For
Else
MsgBox "No attachment found."
Exit For
End If
Next
End If
End If
Next
Else
MsgBox "No emails found."
Exit Sub
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
A separate, but related question. I want to search for emails that are in the Outlook Archive folder, or even a subfolder of Inbox. Do I need to format this line of code any differently?
Set olInb = olns.GetDefaultFolder(6)
Of course, iterating over all items in a folder is not really a good and right idea. You need to use the Restrict or Find/FindNext methods of the Items class to get only items that correspond to your conditions. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
In the code posted above I've noticed the following line:
Set olMail = olInb.Items.Restrict("[Subject] = ""*Blue Recruit Req Data*""")
Be aware, the Restrict methods return an instance of the Items class which contains a collection of items that correspond to your condition, not a single item as you could think. For example:
Sub MoveItems()
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myRestrictItems As Outlook.Items
Dim myItem As Outlook.MailItem
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = _
myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myFolder.Items
Set myRestrictItems = myItems.Restrict("[Subject] = ""*Blue Recruit Req Data*""")
For i = myRestrictItems.Count To 1 Step -1
myRestrictItems(i).Move myFolder.Folders("Business")
Next
End Sub
Also, I'd change the filter string to include entries that may contain the passed substring:
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & wordsInSubject & " %'"
To get items ordered, i.e. start from the recent or oldest ones you need to sort the collection by using the Sort methods of the Items class:
Items.Sort("[ReceivedTime]")
Finally, you may also find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Read more about the AdvancedSearch method and find the sample code in the Advanced search in Outlook programmatically: C#, VB.NET article.
I have refactored some of your code so you can take advantage of calling procedures and organize your logic.
I didn't include all of your code though, but as I can see, you have enough knowledge to make it work.
A couple of suggestions:
1- Use option explicit at the top of your modules
2- Try to define your variables to something meaningful (use names anybody can understand)
3- Try to indent your code consistently (you could use RubberDuck
Before pasting your code:
Use early binding to set the reference to Outlook object library and take advantage of intellisense and other benefits
1) Click on tools | References
2) Check the Microsoft Outlook XXX Object Library
Here is the refactored code:
Execute it using F8 key and adjust it to fit your needs
Public Sub CheckEmail_BlueRecruit()
' Declare objects
Dim outlookApp As Outlook.Application
Dim outlookNamespace As Outlook.Namespace
Dim outlookFolder As Outlook.MAPIFolder
' Declare other variables
Dim filterKeywords As String
Dim filter As String
' Init objects
Set outlookApp = New Outlook.Application
Set outlookNamespace = Outlook.GetNamespace("MAPI")
Set outlookFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
' Init other variables
filterKeywords = "financial"
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & filterKeywords & " %'"
' Loop through folders
LoopFolders outlookFolder, filter
End Sub
Private Sub LoopFolders(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)
' DeclareObjects
Dim outlookSubFolder As Outlook.MAPIFolder
Dim outlookMail As Outlook.MailItem
ProcessFolder outlookFolder, filter
If outlookFolder.Folders.Count > 0 Then
For Each outlookSubFolder In outlookFolder.Folders
LoopFolders outlookSubFolder, filter
Next
End If
End Sub
Private Sub ProcessFolder(ByVal outlookFolder As Outlook.MAPIFolder, ByVal filter As String)
Dim outlookItems As Outlook.Items
Dim outlookMail As Outlook.MailItem
' Filter folder
Set outlookItems = outlookFolder.Items.Restrict(filter)
If Not outlookItems Is Nothing Then
For Each outlookMail In outlookItems
If outlookMail.Attachments.Count <> 0 Then
Debug.Print outlookMail.Subject
End If
Next outlookMail
End If
End Sub
Let me know if it works and you need any more help

How to create a time trigger that would send the mails every week

I would like to ask you for a favour. I got a spreadsheet with code that sends an email if the cell (I3) contains a txt "YES".
Basically, if cell (J3) is empty then (I3) return the value "YES", then the code sends an email to addresses in cell (B3) once it's done it, the date appears to the cell (J3) and the value in (I3) changes to "NO". So on the next occasion the code knows that no emails needs to be send to to particular person.
I got this code of the internet. Done a little modification to the code to suit the sheet1. I'm very new to this, please be patient with me.
In cell (C3) I have the start date, cell (H3) the finish/due date. I would like my spreadsheet to send emails automatically without me opening the workbook.
I would like a time trigger that would send emails if particular task is due in 30 days and if an email could be generated each monday until it reaches 0 days and then one email for overdue - 5.
Not sure if the cell (I3) or (J3) could be still in use.
I hope I explained everything clearly.
Dim uRange
Dim lRange
Dim BCell As Range
Dim iBody As String
Dim iTo As String
Dim iSubject As String
Dim DaysOverdue
Public Sub SetEmailParams()
Set uRange = Sheet1.Range("I2")
Set lRange = Sheet1.Range("I" & Rows.Count).End(xlUp)
iBody = Empty
iSubject = Empty
iTo = Empty
For Each BCell In Range(uRange, lRange)
If BCell.Value = "YES" Then
If DateDiff("d", Format(Now(), "dd/mm/yyyy"), Format(Range("G3"),
"dd/mm/yyyy")) <= 0 Then
DaysOverdue = DateDiff("d", Format(BCell.Offset(0, -6)),
Format(BCell.Offset(0, -1)))
iTo = BCell.Offset(0, -7).Value
iSubject = "Reminder"
iBody = "The job assigned to you under this describtion - " &
BCell.Offset(0, -4) & " in the name of " & BCell.Offset(0, -3) & " for the
confirmation date of " & BCell.Offset(0, -1) & " is due " & DaysOverdue & "
days."
SendEmail
BCell.Offset(0, 1).Value = Now()
End If
End If
Next BCell
End Sub
Private Sub SendEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = iTo
.CC = ""
.BCC = ""
.Subject = iSubject
.Body = iBody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Send to automatically send without displaying
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
For sending automatic mails you can use SendInBlue APIs or mail gun
For converting excel sheet use sheetjs
i hope it helps
You could create a BAT FILE, that open this workbooks and when the workbooks has open then run a Auto_Open macro that reads all cells content.
In ThisWorkbook write this code:
Private Sub Workbook_Open()
MsgBox "Welcome"
End Sub
This is a example of the BAT file i mentioned before:
1.- Open a notepad
2.- Write this:
start Excel.exe "C:\Temporal\TEST.xlsm"
3.- Save it as MyBat.bat
4.- Go to Panel Control --> Administrative tools --> Task Scheduler --> Create a Basic Task
5.- Set the time you want to execute this bat file!
I hope this works for you!
Cheers!
Referring to my comments an Example of using Mail.DeferredDeliveryTime is given below.
This sample sends every email with a certain subject the next Monday at 8 o'clock in the morning.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim Mail As Outlook.MailItem
If TypeOf Item Is Outlook.MailItem Then
Set Mail = Item
If Mail.Subject = "sample" Then
Mail.DeferredDeliveryTime = GetNextWeekday(vbMonday) & " 08:00 AM"
End If
End If
End Sub
Private Function GetNextWeekday(ByVal DayOfWeek As VbDayOfWeek) As Date
Dim diff As Long
diff = DayOfWeek - Weekday(Date, vbSunday)
If diff > 0 Then
GetNextWeekday = DateAdd("d", diff, Date)
Else
GetNextWeekday = DateAdd("d", 7 + diff, Date)
End If
End Function

Get email address from Outlook GAL?

I have the following code to try and grab the GAL from Outlook and drop the person's name + their email address into another sheet.
It gets the first name (but not email address) then stops. If I comment out Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.PrimarySmtpAddress, it lists all the names succesfully, which suggests I might be using the wrong type to get the email address. VBA has no intellisense though so I'm not sure what to use instead!
Private Sub UpdateEmails()
' Need to add reference to Outlook
' Adds addresses to existing Sheet called Emails and
' defines name NamesAndEmailAddresses containing this list
On Error GoTo error
Dim objOutlook As Outlook.Application
Dim objAddressList As Outlook.AddressList
Dim objAddressEntry As Outlook.AddressEntry
Dim intCounter As Integer
Application.ScreenUpdating = False
' Setup connection to Outlook application
Set objOutlook = CreateObject("Outlook.Application")
Set objAddressList = objOutlook.Session.AddressLists("Global Address List")
Application.EnableEvents = False
' Clear existing list
Sheets("Emails").Range("A:A").Clear
'Step through each contact and list each that has an email address
For Each objAddressEntry In objAddressList.AddressEntries
If objAddressEntry.Address <> "" Then
intCounter = intCounter + 1
Application.StatusBar = "Processing no. " & intCounter & " ... " & objAddressEntry.Address
Sheets("Emails").Cells(intCounter, 1) = objAddressEntry.Name
Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.PrimarySmtpAddress
DoEvents
End If
Next objAddressEntry
' Define range called "NamesAndEmailAddresses" to the list of emails
Sheets("Emails").Cells(1, 2).Resize(intCounter, 1).Name = "NamesAndEmailAddresses"
error:
Set objOutlook = Nothing
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Looking at the AddressEntry Object (Outlook) page on MSDN, the property you want is AddressEntry.Address
Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.Address
Also, if you early-bind Outlook from the Tools > References...* then you will get Intellisense. Or, you can hit [Alt]+[F11] in Outlook and use the Intellisense there.
{EDIT} Since this is giving the path on the Exchange Server rather than as a full e-mail address
If the Contact is in an Exchange Address List, then you can use .GetExchangeUser.PrimarySmtpAddress to get the Primary Smtp Address for the user on the Exchange Server. (For local contacts on your account, use the GetContact.Email1Address instead)
Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.GetExchangeuser.PrimarySmtpAddress
To obtain or check if a person has an email address on the GAL:
(see this solution)
Sub testGetEmail()
Debug.Print GetEmailName("Dupont", "Alain")
End Sub
Function GetEmailName(FirstName As String, SecondName As String) As String
Dim oExUser As Outlook.ExchangeUser
Dim oAL As Outlook.AddressList
Set oAL = Application.Session.AddressLists.Item(["Global Address List"])
FullName = FirstName & ", " & SecondName
Set oExUser = oAL.AddressEntries.Item([FullName]).GetExchangeUser
GetEmailName = oExUser.PrimarySmtpAddress
End Function

How to reference Text to respective email address using VBA

so I have set up an emailing system in which emails are sent out to people that own a specific item that have a due date coming up. There are at least 1,000 items on my excel sheet and each item has a specific owner. However the owners are labeled using an ID. The ID refers to an email address in another sheet called "Permissions" . My email function works, however I am having trouble with my recepients. I am not able to match the ID on the sheet that has the items to the email address in the other sheet. I am fairly new to VBA so please excuse my code. I am still learning. Thank you!
The worksheet name "Register" is the worksheet with all of the items and due dates.
Code :
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
I think I am able to follow what the issue is here. It doesn't look like your code is using any vlookup formula or matching formula to find the email. Unless they are on the same row between the different sheets, you will need to find the value.
VBA has the ability to use the functions that you would normally use in Excel.
If you tweek the code below with the correct range and column number, you should be able to find the correct email address based on an 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)

Resources