如何將具有特定主題的Outlook收件箱中的郵件項目移動到特定的文件夾/子文件夾？

Question

我在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

我會使用明確的引用而不是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 

有辦法，你可以檢查，而無需使用一個循環，以及如查找方法

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 2

你有幾個選項來做到這一點，無痛一個是從內部運行Outlook VBA代碼所以你不需要經歷大量的引用問題，但同時如果你堅持要在Excel文件中包含主題和文件夾列表，那麼最好從Excel運行它，但是在這裏是問題：你最好不要嘗試從Excel運行代碼，因爲Microsoft不支持該方法，所以最好的方法是在Excel VBA中編寫代碼，然後再次您可以執行遲到（運行時）綁定或早期綁定，但我更願意使用早期綁定來使用intellisence來更好地引用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）並單擊確定。

建議：

你可以開發的代碼更無視matchcase。要做到這一點替換此行：

arr(i, 1) = Item.Subject 

有：

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

此外，您還可以將包含主題，而不是匹配的確切名稱的電子郵件，例如，如果電子郵件主題有「測試「，或以」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 

希望這有助於！請按複選標記，使這是正確的答案，你的問題，如果它確實

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