遍历Outlook已发送邮件更新Excel：IF语句问题排查

首先，你怀疑的If语句确实是核心问题，另外还有几个小细节需要调整，咱们一步步来解决：

1. 最关键的If语句语法错误 #

你原来的代码里这一行：

If InStr(LCase(Cells(iRows, 5)), cell.Value > 0) And InStr(LCase(Cells(iRows, 5)), LCase("GTPRM")) > 0 Then

这里的cell.Value > 0是把一个布尔值（True/False）传给了InStr的第二个参数，这完全不对！InStr的正确用法是InStr(字符串1, 字符串2)，返回字符串2在字符串1中的位置，大于0就表示存在。而且为了大小写不敏感，应该把cell.Value也转成小写，所以正确的写法是：

If InStr(LCase(Cells(iRows, 5).Value), LCase(cell.Value)) > 0 And InStr(LCase(Cells(iRows, 5).Value), LCase("GTPRM")) > 0 Then

另外，最好加上.Value明确引用单元格的值，避免潜在的对象引用问题。

2. Late Binding下的常量缺失 #

你用的是Late Binding（CreateObject("Outlook.Application")），这种方式不会自动识别Outlook的内置常量，比如olFolderSentMail和olMail，所以必须在代码开头手动定义这些常量，否则会报错：

' 手动定义Outlook常量（Late Binding必备）
Const olFolderSentMail As Integer = 5
Const olMail As Integer = 43

3. 避免工作表激活，明确引用目标表 #

直接用Activate和Cells容易因为当前工作表切换而出错，最好直接引用目标工作表对象，比如：

Dim sentSheet As Worksheet
Set sentSheet = ThisWorkbook.Sheets("Sent_Email")

' 替换原来的Cells(iRows, 1) = ... 为：
sentSheet.Cells(iRows, 1).Value = objMail.Recipients(1)
sentSheet.Cells(iRows, 2).Value = objMail.To
sentSheet.Cells(iRows, 3).Value = objMail.Subject
sentSheet.Cells(iRows, 4).Value = objMail.ReceivedTime
sentSheet.Cells(iRows, 5).Value = objMail.Body

4. 筛选范围的错误处理 #

如果MyRange没有被筛选，SpecialCells(xlCellTypeVisible)会抛出错误，建议加个错误捕获：

On Error Resume Next
Set FiltRange = MyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo ErrHandler
' 如果没有筛选结果，直接退出循环或者提示
If FiltRange Is Nothing Then
    MsgBox "没有可见的筛选记录！"
    Exit Sub
End If

完整修正后的代码 #

Option Explicit
' 手动定义Outlook常量（Late Binding必备）
Const olFolderSentMail As Integer = 5
Const olMail As Integer = 43

Private Sub CommandButton1_Click()
On Error GoTo ErrHandler
    ' Set Outlook application object.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
    
    Dim objNSpace As Object
    ' Create and Set a NameSpace OBJECT.
    Set objNSpace = objOutlook.GetNamespace("MAPI")
    
    Dim myFolder As Object
    ' Create a folder object.
    Set myFolder = objNSpace.GetDefaultFolder(olFolderSentMail)
    
    Dim objItem As Object
    Dim iRows As Integer, iCols As Integer ' 注意：原来的iRows没指定类型，默认Variant，这里改成Integer
    Dim sFilter As String
    iRows = 2
    
    Dim MyRange As Range
    Dim cell As Range
    Dim Wb As Workbook
    Dim FiltRange As Range
    Dim dataSheet As Worksheet
    Dim sentSheet As Worksheet
    
    ' 明确引用工作表，避免激活
    Set Wb = Workbooks("RIRQ and RRTNs with LOB Sept 28 2020")
    Set dataSheet = Wb.Worksheets("Data")
    Set sentSheet = ThisWorkbook.Sheets("Sent_Email")
    
    ' select the records in column A
    Set MyRange = dataSheet.Range(dataSheet.Cells(2, 1), dataSheet.Range("A1").End(xlDown))
    
    'only select the filtered records，加错误处理
    On Error Resume Next
    Set FiltRange = MyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo ErrHandler
    If FiltRange Is Nothing Then
        MsgBox "没有找到可见的筛选记录，请先设置筛选！"
        GoTo Cleanup
    End If
    
    'create a filter for emails marked as not completed
    sFilter = "[Categories] = 'Not Completed'"
    
    ' Loop through each item in the folder.
    'loop through the emails in the sent folder restricted to specific category
    For Each objItem In myFolder.Items.Restrict(sFilter)
        If objItem.Class = olMail Then
            Dim objMail As Object ' Late Binding用Object代替Outlook.MailItem
            Set objMail = objItem
            
            'extract data from email，明确引用sentSheet
            sentSheet.Cells(iRows, 1).Value = objMail.Recipients(1)
            sentSheet.Cells(iRows, 2).Value = objMail.To
            sentSheet.Cells(iRows, 3).Value = objMail.Subject
            sentSheet.Cells(iRows, 4).Value = objMail.ReceivedTime
            sentSheet.Cells(iRows, 5).Value = objMail.Body
            
            'loop throug the records on the spreadsheet to find matches
            For Each cell In FiltRange
                '修正后的If语句
                If InStr(LCase(sentSheet.Cells(iRows, 5).Value), LCase(cell.Value)) > 0 And _
                   InStr(LCase(sentSheet.Cells(iRows, 5).Value), LCase("GTPRM")) > 0 Then
                    Debug.Print cell.Value
                    ' 这里明确引用dataSheet的单元格，避免当前表错误
                    dataSheet.Cells(cell.Row, 35).Value = sentSheet.Cells(iRows, 4).Value
                End If
            Next cell
        End If
        iRows = iRows + 1
    Next

Cleanup:
    ' Release objects
    Set objMail = Nothing
    Set objOutlook = Nothing
    Set objNSpace = Nothing
    Set myFolder = Nothing
    Set dataSheet = Nothing
    Set sentSheet = Nothing
    Set MyRange = Nothing
    Set FiltRange = Nothing
    Exit Sub

ErrHandler:
    MsgBox "发生错误：" & Err.Description
    Debug.Print Err.Description
    GoTo Cleanup
End Sub

几个额外的优化说明 #

• 把Dim iRows, iCols As Integer改成Dim iRows As Integer, iCols As Integer，因为VBA里如果不指定类型，前面的变量会是Variant类型，不如明确指定更高效。
• Late Binding下用Object代替Outlook.MailItem，这样不需要引用Outlook库，兼容性更好。
• 增加了Cleanup标签，确保无论是否出错都能释放对象，避免内存泄漏。

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