我来帮你调整代码，实现从Outlook已发送邮件中找到对应发票号的邮件，并把收件人姓名和邮箱返回至W1的功能。先分析下你现有代码里的几个核心问题，再给出完整的修正方案：

现有代码的问题点 #

• 变量引用错误：你在判断邮件主题时用了Like "*c*"，这里的c会被当成字符串"c"，而不是当前循环的发票号变量，应该拼接实际的发票号值
• 循环逻辑脱节：Outlook邮件的循环是在W1发票循环结束后单独执行的，此时FR已经是最后一个匹配的行号，无法对应到每个发票的行
• 收件人属性调用错误：Folder.Items.Item(i).RecipientName不是正确的属性，应该通过olMail.Recipients集合来获取收件人信息
• 效率问题：遍历所有已发送邮件会很慢，建议先筛选主题包含当前发票号的邮件

修正后的完整代码 #

Sub UpdateDunningLog()
    '定义工作簿和工作表对象
    Dim w1 As Worksheet, w2 As Worksheet
    Dim c As Range, FR As Long
    Dim strfilename As String: strfilename = "xyz.xlsx"
    Dim DL As Workbook
    
    'Outlook相关对象
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim sentFolder As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    Dim recip As Outlook.Recipient
    Dim filterStr As String
    
    Application.ScreenUpdating = False
    
    '设置目标工作表（Dunning Log）
    Set w2 = ActiveWorkbook.Sheets("Sheet1")
    
    '打开债务人日志工作簿（后台）
    Set DL = Workbooks.Open(Filename:=strfilename, UpdateLinks:=3)
    Set w1 = DL.Worksheets("Data")
    
    '初始化Outlook应用
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application") '如果Outlook已打开，直接获取
    If Err.Number <> 0 Then
        Set olApp = New Outlook.Application '如果未打开，新建实例
    End If
    On Error GoTo 0
    Set olNS = olApp.GetNamespace("MAPI")
    Set sentFolder = olNS.GetDefaultFolder(olFolderSentMail)
    
    '遍历W1中的发票号（从A4开始）
    For Each c In w1.Range("A4", w1.Range("A" & Rows.Count).End(xlUp))
        FR = 0
        '匹配W2中对应的发票号行
        On Error Resume Next
        FR = Application.Match(c.Value, w2.Columns("E"), 0)
        On Error GoTo 0
        
        '如果找到匹配行，先同步W1中的基础数据
        If FR <> 0 Then
            w2.Range("D" & FR).Value = c.Offset(0, 3).Value '客户名称
            w2.Range("G" & FR).Value = c.Offset(0, 15).Value '发票金额
            w2.Range("H" & FR).Value = c.Offset(0, 41).Value '逾期天数
            
            '构建Outlook邮件筛选条件：主题包含当前发票号
            filterStr = "@SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001F"" LIKE '%" & c.Value & "%'"
            
            '遍历筛选后的邮件（只找主题匹配的）
            For Each olMail In sentFolder.Items.Restrict(filterStr)
                '遍历邮件的收件人，提取姓名和邮箱
                For Each recip In olMail.Recipients
                    '这里假设每个发票对应一封邮件，取第一个收件人；如果有多封，可根据需求调整
                    w2.Range("A" & FR).Value = recip.Name
                    w2.Range("B" & FR).Value = recip.Address
                    Exit For '取第一个收件人后退出循环，可根据需求删除这行
                Next recip
                Exit For '找到第一封匹配的邮件后退出，可根据需求删除这行
            Next olMail
        End If
    Next c
    
    '清理对象
    Set recip = Nothing
    Set olMail = Nothing
    Set sentFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    
    '关闭债务人日志工作簿，不保存
    DL.Close savechanges:=False
    Application.ScreenUpdating = True
End Sub

关键代码解释 #

1. Outlook实例初始化：先尝试获取已打开的Outlook实例，避免重复启动，提升效率
2. 邮件筛选：使用Restrict方法结合SQL筛选语法，只遍历主题包含当前发票号的邮件，比全量遍历快很多
3. 收件人信息提取：通过olMail.Recipients集合遍历收件人，正确获取Name和Address属性
4. 循环逻辑整合：把Outlook邮件的匹配逻辑放到W1发票号的循环里，确保每个发票对应的收件人信息能写入正确的行
5. 错误处理：优化了错误处理的位置，避免掩盖其他错误

注意：使用这段代码前，需要确保在VBA编辑器中引用了Microsoft Outlook XX.X Object Library（通过工具→引用勾选）。

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