拉取主SMTP和其他SMTP上的交换用户信息匹配

Question

我正在使用excel VBA从OneNote中查找粘贴在表单考勤笔记中的列表，我正在从超链接中提取电子邮件。我正在尝试将其与交换用户信息相匹配，以收回前景信息。如果电子邮件与主SMTP地址匹配，我会让它正常工作。有些人从OneNote获得了其他smtp地址(婚前姓名(，但找不到。在Exchange中，主SMTP更改为已婚名称，婚前SMTP变为次要名称。如果主smtp不匹配，我希望能够匹配到辅助smtp。

这是有效的代码。请原谅非高级编码，因为我正在从谷歌搜索中把它拼凑在一起。

获取要传递到Call语句中的电子邮件地址和单元格范围。

Sub Get_Outlook_Data()
Dim rngEmails As Range
Dim cl As Range
Dim clrow As Long
Dim clcell As String
With Worksheets("OneNote Attendance List")
Set rngEmails = Range("B3:" & .Range("B" & .Rows.Count).End(xlUp).Address)
End With
For Each cl In rngEmails
cl.Select
clrow = ActiveCell.Row
clcell = "B" & clrow
If Len(cl.Value) > 0 Then
Call GetOLData(cl.Value, clcell)
Else
'No email in cell, ignore it
End If
Next cl
End Sub

此子组件正在收集SMTP 上的Exchange用户信息

Sub GetOLData(EmailAddress As String, StartCell As String)
Dim OutApp 'As Outlook.Application
Dim OutMail 'As Object
Dim OutRecipients 'As Outlook.Recipient
Dim Alias As String
Dim JobT As String
Dim Dpt As String
Dim City As String
Dim Ste As String
Dim Off As String
Dim Fnm As String
Dim Lnm As String
Dim Dnm As String
Dim PosCd As String
Dim ID As String
Dim Cmpy As String

On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set OutRecipients = OutMail.Recipients.Add(EmailAddress)
OutRecipients.Resolve
Alias = OutRecipients.addressEntry.GetExchangeUser.Alias
JobT = OutRecipients.addressEntry.GetExchangeUser.JobTitle
Dpt = OutRecipients.addressEntry.GetExchangeUser.Department
City = OutRecipients.addressEntry.GetExchangeUser.City
Ste = OutRecipients.addressEntry.GetExchangeUser.SateOrProvince
Off = OutRecipients.addressEntry.GetExchangeUser.OfficeLocation
Fnm = OutRecipients.addressEntry.GetExchangeUser.FirstName
Lnm = OutRecipients.addressEntry.GetExchangeUser.LastName
Dnm = OutRecipients.addressEntry.GetExchangeUser.Name
PosCd = OutRecipients.addressEntry.GetExchangeUser.PostalCode
ID = OutRecipients.addressEntry.GetExchangeUser.ID
Cmpy = OutRecipients.addressEntry.GetExchangeUser.CompanyName
ActiveCell.Offset(0, 1).Value = Alias
ActiveCell.Offset(0, 2).Value = JobT
ActiveCell.Offset(0, 3).Value = Dpt
ActiveCell.Offset(0, 4).Value = City
ActiveCell.Offset(0, 5).Value = Ste
ActiveCell.Offset(0, 6).Value = Off
ActiveCell.Offset(0, 7).Value = Fnm
ActiveCell.Offset(0, 8).Value = Lnm
ActiveCell.Offset(0, 9).Value = Dnm
ActiveCell.Offset(0, 10).Value = PosCd
ActiveDell.Offset(0, 11).Value = ID
ActiveDell.Offset(0, 12).Value = Cmpy

Set OutRecipients = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
On Error GoTo 0
End Sub

任何帮助都将是伟大的。

Answer 1

我要做的第一件事是删除On Error Resume Next，因为它隐藏了所有的问题。如果要进行错误处理，请处理错误。永远不要跳过它并期望运行其余的代码。如果你想跳过那个电子邮件地址并继续前进，那么你会让它在出错时到达sub的末尾。

我还注意到你没有使用"StartCell"，所以我添加了一些使用它的代码

代码清理：

Sub Get_Outlook_Data()
Dim rngEmails As Range
Dim cl As Range
With Worksheets("OneNote Attendance List")
Set rngEmails = .Range("B3:" & .Range("B" & .Rows.Count).End(xlUp).Address)
End With
For Each cl In rngEmails
If Len(cl.Value) > 0 Then
Call GetOLData(cl.Value, "B" & cl.Row)
End If
Next cl
End Sub
Sub GetOLData(EmailAddress As String, StartCell As String)
Dim OutApp                                   'As Outlook.Application
Dim OutMail                                  'As Object
Dim OutRecipients                            'As Outlook.Recipient
'On Error Resume Next ' Never do this
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set OutRecipients = OutMail.Recipients.Add(EmailAddress)
OutRecipients.Resolve
With OutRecipients.addressEntry.GetExchangeUser
ActiveCell.Offset(0, 1).Value = .Alias
ActiveCell.Offset(0, 2).Value = .JobTitle
ActiveCell.Offset(0, 3).Value = .Department
ActiveCell.Offset(0, 4).Value = .City
ActiveCell.Offset(0, 5).Value = .SateOrProvince
ActiveCell.Offset(0, 6).Value = .OfficeLocation
ActiveCell.Offset(0, 7).Value = .FirstName
ActiveCell.Offset(0, 8).Value = .LastName
ActiveCell.Offset(0, 9).Value = .Name
ActiveCell.Offset(0, 10).Value = .PostalCode
ActiveCell.Offset(0, 11).Value = .ID
ActiveCell.Offset(0, 12).Value = .CompanyName
End With
Set OutRecipients = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
'On Error GoTo 0
End Sub