如何将具有特定主题的 Outlook 收件箱中的邮件项目移动到特定文件夹/子文件夹？答案

【问题标题】：How can I move Mails Items from Outlook Inbox with specific subject to specific folder/sub folder?如何将具有特定主题的 Outlook 收件箱中的邮件项目移动到特定文件夹/子文件夹？
【发布时间】：2017-04-29 01:17:48
【问题描述】：

我在 Outlook 中的邮件包含所有特定主题。我有一个包含主题和文件夹名称的 Excel 表。

我已经有来自Stackoverflow的代码

Option Explicit
Public Sub Move_Items()
    '// Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim olNs As Outlook.NameSpace
    Dim Item As Object
    Dim lngCount As Long
    Dim Items As Outlook.Items

    On Error GoTo MsgErr
    '// Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

    '// Loop through the Items in the folder backwards
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items.Item(lngCount)

        Debug.Print Item.Subject

        If Item.Class = olMail Then
            '// Set SubFolder of Inbox
            Set SubFolder = Inbox.Folders("Temp")
            '// Mark As Read
            Item.UnRead = False
            '// Move Mail Item to sub Folder
            Item.Move SubFolder
        End If
    Next lngCount

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing

Exit Sub

'// Error information
MsgErr:
   MsgBox "An unexpected Error has occurred." _
     & vbCrLf & "Error Number: " & Err.Number _
     & vbCrLf & "Error Description: " & Err.Description _
     , vbCritical, "Error!"
  Resume MsgErr_Exit
End Sub

我希望代码读取活动工作表列，如下所示：

Subject.mail   folder_name
    A                1
    B                2
    C                3

例如，主题为“A”的收件箱中的邮件，则必须将该邮件放在文件夹“1”中。

如何循环播放？查看 Sheet1 并读取它必须移动到哪个子文件夹？

【问题讨论】：

您考虑过 Outlook 邮件规则吗？他们可以为您做到这一点。您可以使用非常具体的标准指定将邮件移动到何处。

标签： excel vba outlook

【解决方案1】：

你有几个选项可以做到这一点，最简单的方法是从 Outlook 内部运行 Outlook VBA 代码，这样你就不需要经历很多引用问题，但同时如果你坚持让你的Excel 文件中的主题和文件夹列表，那么最好从 Excel 运行它，但问题是：您最好不要尝试从 Excel 运行代码，因为 Microsoft 不支持该方法，所以最好的方法是在 Excel VBA 中编写代码，同样您可以进行后期（运行时）绑定或早期绑定，但我更喜欢早期绑定使用智能来更好地引用 Outlook 对象并避免后期绑定性能和/或调试问题。

这里是代码以及你应该如何使用它：

转到包含主题和文件夹列表的 Excel 文件或创建一个新文件。按 ALT+F11 进入 VBE。在左侧面板（项目资源管理器）上，右键单击并插入一个模块。把这段代码粘贴进去：

Option Explicit
Public Sub MoveEmailsToFolders()
    'arr will be a 2D array sitting in an Excel file, 1st col=subject, 2nd col=folder name
    '   // Declare your Variables
    Dim i As Long
    Dim rowCount As Integer
    Dim strSubjec As String
    Dim strFolder As String

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim myFolder As Outlook.Folder
    Dim Item As Object

    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder

    Dim lngCount As Long
    Dim Items As Outlook.Items
    Dim arr() As Variant 'store Excel table as an array for faster iterations
    Dim WS As Worksheet

    'On Error GoTo MsgErr

    'Set Excel references
    Set WS = ActiveSheet
    If WS.ListObjects.Count = 0 Then
        MsgBox "Activesheet did not have the Excel table containing Subjects and Outlook Folder Names", vbCritical, "Error"
        Exit Sub
    Else
        arr = WS.ListObjects(1).DataBodyRange.Value
        rowCount = UBound(arr, 2)
        If rowCount = 0 Then
            MsgBox "Excel table does not have rows.", vbCritical, "Error"
            Exit Sub
        End If
    End If


    'Set Outlook Inbox Reference
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set myFolder = olNs.GetDefaultFolder(olFolderInbox)

    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

      '   // Loop through the Items in the folder backwards
      For lngCount = Items.Count To 1 Step -1
        strFolder = ""
        Set Item = Items.Item(lngCount)

        'Debug.Print Item.Subject

        If Item.Class = olMail Then
            'Determine whether subject is among the subjects in the Excel table
            For i = 1 To rowCount
                If arr(i, 1) = Item.Subject Then
                    strFolder = arr(i, 2)

                    '// Set SubFolder of Inbox, read the appropriate folder name from table in Excel
                    Set SubFolder = Inbox.Folders(strFolder)
                    '// Mark As Read
                    Item.UnRead = False
                    '// Move Mail Item to sub Folder
                    Item.Move SubFolder
                    Exit For
                    End If
                Next i
            End If

      Next lngCount

  MsgErr_Exit:
    Set Inbox = Nothing
      Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing

    Exit Sub

 '// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
  Resume MsgErr_Exit
End Sub

设置参考：

要使用 Outlook 对象，请在 Excel VBE 中转到工具、参考并检查 Microsoft Outlook 对象库。

设置 Excel 工作表：

在 Excel 工作表中，创建一个包含两列的表格，第一列包含电子邮件主题，第二列包含您希望将这些电子邮件移动到的文件夹。

然后，插入一个形状并右键单击它并分配一个宏，找到宏的名称（MoveEmailsToFolders）并单击确定。

建议：

您可以更多地开发代码以忽略匹配大小写。为此，请替换此行：

arr(i, 1) = Item.Subject

与：

Ucase(arr(i, 1)) = Ucase(Item.Subject)

此外，您可以移动包含主题而不是匹配确切标题的电子邮件，例如，如果电子邮件主题有“test”，或以“test”开头，或以“test”结尾，则将其移动到对应的文件夹。然后，比较子句将是：

 If arr(i, 1) Like Item.Subject & "*" Then 'begins with
 If arr(i, 1) Like  "*" & Item.Subject & "*" Then 'contains
 If arr(i, 1) Like  "*" & Item.Subject Then 'ends with

希望这会有所帮助！如果确实如此，请点击复选标记以使其成为您问题的正确答案

【讨论】：

【解决方案2】：

除非您实际上是在一堆不同的工作表上运行宏，否则我会使用对工作表的显式引用而不是 ActiveSheet。我只是假设您的数据位于 A 列和 B 列中，并从第 2 行开始，例如。这就是您循环数据并尝试匹配主题的方式，然后将其移动到具有下一列中名称的文件夹（如果匹配）。

If Item.Class = olMail Then

    For i = 2 To ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row

        If ActiveSheet.Range("A" & i).Value = Item.Subject Then
              '// Set SubFolder of Inbox
            Set SubFolder = Inbox.Folders(ActiveSheet.Range("B" & i).Value)
               '// Mark As Read
            Item.UnRead = False
               '// Move Mail Item to sub Folder
            Item.Move SubFolder
        End If

    Next

End If

还有一些方法可以在不使用循环的情况下进行检查，例如 Find 方法

Dim rnFind As Range

If Item.Class = olMail Then

    Set rnFind = ActiveSheet.Range("A2", ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp)).Find(Item.Subject)

        If Not rnFind Is Nothing Then
              '// Set SubFolder of Inbox
            Set SubFolder = Inbox.Folders(rnFind.Offset(, 1).Value)
               '// Mark As Read
            Item.UnRead = False
               '// Move Mail Item to sub Folder
            Item.Move SubFolder
        End If

End If

【讨论】：

我认为代码不起作用，因为原始代码是 Outlook vba，而您将其与 excel vba 混合而没有正确引用
是的，这是真的，我认为 VBA 是在 Excel 中，因为他在询问如何使用 Excel 数据进行操作。添加对 Excel 工作簿的引用并在其中有适当的工作表引用会很容易。无论如何，用 VBA 中的数组来完成整个事情可能会更容易，除非实际上有一个巨大的数据集，其中包含他们试图这样分类的独特电子邮件主题。

【解决方案3】：

使用Do Until IsEmpty loop，一定要设置Excel Object Referees...

请参阅有关如何从 Outlook 循环的示例...

Option Explicit
Public Sub Move_Items()
    '// Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim olNs As Outlook.NameSpace
    Dim Items As Outlook.Items
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim Item As Object
    Dim ItemSubject As String
    Dim SubFldr As String
    Dim lngCount As Long
    Dim lngRow As Long

    On Error GoTo MsgErr
    '// Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

    '// Excel Book Reference
    Set xlApp = New Excel.Application
    Set xlBook = xlApp.Workbooks.Open("C:\Temp\Book1.xlsx") ' Excel Book Path

    lngRow = 2 ' Start Row

    With xlBook.Worksheets("Sheet1") ' Sheet Name

        Do Until IsEmpty(.Cells(lngRow, 1))
            ItemSubject = .Cells(lngRow, 1).Value ' Subject
            SubFldr = .Cells(lngRow, 2).Value ' Folder Name

            '// Loop through the Items in the folder backwards
            For lngCount = Items.Count To 1 Step -1
                Set Item = Items.Item(lngCount)

                If Item.Class = olMail Then

                    If Item.Subject = ItemSubject Then

                        Debug.Print Item.Subject
                        Set SubFolder = Inbox.Folders(SubFldr) ' Set SubFolder

                        Debug.Print SubFolder
                        Item.UnRead = False ' Mark As Read
                        Item.Move SubFolder ' Move to sub Folder

                    End If

                End If
            Next
            lngRow = lngRow + 1
        Loop
    End With

    xlBook.Close

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing
    Set xlApp = Nothing
    Set xlBook = Nothing

Exit Sub

'// Error information
MsgErr:
   MsgBox "An unexpected Error has occurred." _
     & vbCrLf & "Error Number: " & Err.Number _
     & vbCrLf & "Error Description: " & Err.Description _
     , vbCritical, "Error!"
  Resume MsgErr_Exit
End Sub

【讨论】：