通过VBA匹配Outlook收件箱姓名填充Excel客户表邮箱列

当然可以用VBA实现，但你当前的代码效率极低，这就是为啥跑4小时还没动静的原因。下面给你分析问题并提供优化后的代码：

原代码的核心问题 #

• 嵌套循环效率爆炸：外层遍历Excel每行数据，内层遍历收件箱所有邮件，数据量大时（比如几百行Excel+几千封邮件），总运算量直接翻倍，完全拖慢速度
• 无提前过滤：每次循环都判断邮件类型，没提前筛选出仅邮件类的项
• 未利用Outlook搜索能力：硬遍历所有邮件太冗余，Outlook本身支持高效检索

优化后的代码 #

Sub FillEmails_Fast()
    Dim customerSheet As Worksheet
    Dim customerLastRow As Long
    Dim i As Long
    Dim customerName As String
    Dim olApp As Object
    Dim olNamespace As Object
    Dim olFolder As Object
    Dim olItems As Object
    Dim olItem As Object
    Dim nameEmailDict As Object ' 用字典存储姓名-邮箱映射，实现快速查找
    
    ' 关闭Excel屏幕刷新，提升运行速度
    Application.ScreenUpdating = False
    
    Set customerSheet = ThisWorkbook.Sheets("Customer")
    Set nameEmailDict = CreateObject("Scripting.Dictionary")
    
    ' 初始化Outlook对象
    Set olApp = CreateObject("Outlook.Application")
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(6) ' 对应收件箱
    ' 提前筛选出仅邮件类型的项，减少遍历数量
    Set olItems = olFolder.Items.Restrict("[Class] = 43")
    
    ' 先遍历一次Outlook邮件，把姓名和邮箱存入字典
    For Each olItem In olItems
        If olItem.SenderName <> "" And olItem.SenderEmailAddress <> "" Then
            ' 避免重复姓名覆盖，这里保留第一个匹配的邮箱，可按需调整
            If Not nameEmailDict.Exists(olItem.SenderName) Then
                nameEmailDict.Add olItem.SenderName, olItem.SenderEmailAddress
            End If
        End If
    Next olItem
    
    ' 遍历Excel填充邮箱
    customerLastRow = customerSheet.Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To customerLastRow
        customerName = customerSheet.Cells(i, "A").Value
        ' 直接从字典取邮箱，无需再次遍历Outlook
        If nameEmailDict.Exists(customerName) Then
            customerSheet.Cells(i, "D").Value = nameEmailDict(customerName)
        Else
            customerSheet.Cells(i, "D").Value = "" ' 无匹配时留空
        End If
    Next i
    
    ' 清理对象
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
    Set nameEmailDict = Nothing
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    MsgBox "邮箱填充完成！"
End Sub

优化点说明 #

• 字典存储映射：只遍历一次Outlook收件箱，把所有发件人姓名和邮箱存入字典，之后Excel每行直接查字典，时间复杂度从O(N*M)降到O(N+M)
• 提前筛选邮件：用Restrict方法直接过滤出邮件类项，减少遍历对象数量
• 关闭屏幕刷新：避免Excel频繁更新界面，大幅提升运行速度

内容的提问来源于stack exchange，提问作者speedprogg