Sub
GetEmailAddresses()
Dim
olApp
As
Object
Dim
olNamespace
As
Object
Dim
olContacts
As
Object
Dim
olContact
As
Object
Dim
ws
As
Worksheet
Dim
lastRow
As
Long
Dim
i
As
Long
Dim
name
As
String
Dim
emailAddress
As
String
Dim
nameParts()
As
String
Dim
searchName1
As
String
Dim
searchName2
As
String
Set
ws = ActiveSheet
Set
olApp = CreateObject(
"Outlook.Application"
)
Set
olNamespace = olApp.GetNamespace(
"MAPI"
)
Set
olContacts = olNamespace.GetDefaultFolder(10).Items
lastRow = ws.Cells(ws.Rows.Count,
"A"
).
End
(xlUp).Row
For
i = 1
To
lastRow
name = ws.Cells(i, 1).Value
emailAddress =
""
nameParts = Split(name,
" "
)
If
UBound(nameParts) = 1
Then
searchName1 = nameParts(0) &
" "
& nameParts(1)
searchName2 = nameParts(1) &
" "
& nameParts(0)
Else
searchName1 = name
searchName2 = name
End
If
For
Each
olContact
In
olContacts
If
InStr(1, olContact.FullName, searchName1, vbTextCompare) > 0
Or
InStr(1, olContact.FullName, searchName2, vbTextCompare) > 0
Then
emailAddress = olContact.Email1Address
Exit
For
End
If
Next
olContact
ws.Cells(i, 2).Value = emailAddress
Next
i
Set
olContact =
Nothing
Set
olContacts =
Nothing
Set
olNamespace =
Nothing
Set
olApp =
Nothing
End
Sub