X500 Address shows instead of email address when transferring to Excel sheet

[LopezChris96]

So I have been tasked with getting a list of all the users who sent mail to a mailbox in Outlook and transferring it to an excel sheet. Specifically, the sender's name, email address, as well as retrieving the sender's alias from the GAL address book. I've figured out how to do it, but I've run into two major problems:


For a somewhat large amount of the users, instead of their email address transferring, the X500 address is what shows up as follows: /O=OREGON STATE UNIVERSITY/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN //This is just an example I found online but the format is exactly the way it shows up in the excel sheet.
The alias for one user sometimes gets repeated to the wrong user. This also is happening to a somewhat large amount of users. What could be causing this? How can I fix this problem so the email address shows up and the correct alias is transferred to its respective user? //I feel it's also important to note that in the mailbox where I am transferring the information, several users actually emailed to it more than once. Could that be what's causing the problem with the user's alias?

Also I'm a beginner in VBA, so maybe not getting too technical would be helpful. Thanks in advance.
Here's the code I have (which the majority of I found online):

Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim oAL As Outlook.AddressList
Dim olAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry

Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColB, strColC, strColD As String



enviro = CStr(Environ("USERPROFILE"))
'where to find excel sheet
strPath = enviro & "\Documents\EmailList.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If

'Where to transfer the info
Set xlWB = xlApp.workbooks.Open(strPath)
Set xlSheet = xlWB.sheets("Sheet1")


'Find the next empty line of the worksheet
rCount = xlSheet.Range("C" & xlSheet.Rows.Count).End(4000).Row

' where to find the information
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj

'extract the information

strColB = olItem.SenderName
strColC = olItem.SenderEmailAddress
strColD = olItem.Sender.GetExchangeUser.Alias


'Get the Exchange address
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.session.CreateRecipient(strColB)

If InStr(1, strColC, "/") > 0 Then
'if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
End Select
End If

'write them in the excel sheet
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("C" & rCount) = strColC
xlSheet.Range("D" & rCount) = strColD

'Next row
rCount = rCount + 1

Next

xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If

Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing Set xlSheet = Nothing