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

我在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并阅读到哪个子文件夹，它必须移动？

Answer 1

你没有办法做到这一点，无痛的是从Outlook里面运行Outlook VBA代码，所以你不需要经历很多的引用问题，但同时如果你坚持让你的主题列表和文件夹在Excel文件中，那么最好从Excel运行它，但这是问题：你最好不要尝试从Excel运行的代码，因为微软不支持该方法，所以最好的办法是写Excel VBA中的代码，并且可以执行迟到（运行时）绑定或早期绑定，但是我更喜欢使用intellisence进行早期绑定，以便更好地引用Outlook对象，并避免后期绑定性能和/或debugging问题。

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

转到你有你的主题和文件夹列表的Excel文件或创build一个新的。 按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工作表中，创build一个包含两列的表格，第一列包含电子邮件主题，第二列包含要将这些电子邮件移动到的文件夹。

然后，插入一个形状，然后右键单击并指定macros，findmacros的名称（MoveEmailsToFolders）并单击确定。

build议：

您可以更多地开发代码来忽略匹配。 要做到这一点，取代这一行：

 arr(i, 1) = Item.Subject 

有：

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

此外，您可以移动包含主题的电子邮件，而不是匹配确切的标题，例如，如果电子邮件主题具有“testing”，或以“testing”开头，或以“testing”结尾，则将其移至相应的文件夹。 那么比较条款是：

  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 

希望这可以帮助！ 如果确实如此，请打上勾号将其作为您的问题的正确答案

Answer 2

我会使用一个明确的引用到你的工作表，而不是ActiveSheet，除非你真的在一堆不同的工作表上运行macros。 我只是假设你的数据是在列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 

Answer 3

使用Do Until IsEmpty loop ，请确保设置Excel对象裁判…

请参阅示例以了解如何从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