Question

我正在使用excel VBA从OneNote中查找一个列表，该列表粘贴在我从超链接中提取电子邮件的表单出勤记录中。我正在尝试将其与交换用户信息匹配，以撤回Outlook信息。如果电子邮件与主SMTP地址匹配，我可以正常工作。有些是通过OneNote的其他smtp地址（结婚前的姓名）输入的，找不到这些地址。在Exchange中，主要SMTP更改为已婚名称，婚前smtp成为次要名称。我希望能够与次要smtp匹配。

这是有效的代码。原谅非高级编码，因为我正在通过Google搜索将其修补在一起。

获取电子邮件地址和单元格范围以传递到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，因为它隐藏了您的所有问题。如果要执行错误处理，请处理错误。永远不要只跳过它，并期望其余代码能够运行。如果要跳过该电子邮件地址并继续前进，则可以将其转到出现错误的子标题的末尾。

我还注意到您没有使用“ 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

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

1 个答案: