Extract email address from outlook for a list of employee ids - vba

Question

I am almost done with the code, however I'm only able to pull a single employee ID id. Refer to the code below:
Private Sub CommandButton24_Click()
Dim outApp As Object 'Application
Dim outTI As Object 'TaskItem
Dim outRec As Object 'Recipient
Dim outAL As Object 'AddressList
Set outApp = GetObject(, "Outlook.Application")
Set outAL = outApp.Session.AddressLists.Item("Global Address List")
Set outTI = outApp.CreateItem(3)
outTI.Assign
Set outRec = outTI.Recipients.Add(Range("A2").Value)
outRec.Resolve
If outRec.Resolved Then
Range("B2").Value = outAL.AddressEntries(outRec.AddressEntry.Name).GetExchangeUser.PrimarySmtpAddress
Else
MsgBox "Couldn't find Employee"
End If
End Sub
Looks like some changes need to be made in this code so that I can extract email address from the list.
Set outRec = outTI.Recipients.Add(Range("A2").Value)

Answer 1

If your list is on Column A then Try looping through column
Example
Option Explicit
Private Sub CommandButton24_Click()
Dim olApp As Object 'Application
Dim olTaskItem As Object 'TaskItem
Dim olRecip As Object 'Recipient
Dim olAddList As Object 'AddressList
Set olApp = GetObject(, "Outlook.Application")
Set olAddList = olApp.Session.AddressLists.Item("Global Address List")
Set olTaskItem = olApp.CreateItem(3)
Dim i As Long
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
olTaskItem.Assign
Set olRecip = olTaskItem.Recipients.Add(Cells(i, 1).Value)
olRecip.Resolve
If olRecip.Resolved Then
Cells(i, 2).Value = olAddList.AddressEntries(olRecip.AddressEntry.Name).GetExchangeUser.PrimarySmtpAddress
Else
MsgBox "Couldn't find Employee"
End If
Next i
End Sub