如何在Outlook中將兩個資料夾合併到一個資料夾且不包含重複項目？

Author: Sun Last Modified: 2025-05-13

在Outlook中，您可能有多個郵件帳號和許多資料夾。在某些情況下，您希望將兩個資料夾合併為一個，並刪除重複的項目。該如何快速完成這項工作呢？本文介紹了一段VBA代碼，幫助您在Outlook中盡快處理此問題。

使用VBA代碼合併兩個資料夾且不包含重複項目

使用Kutools for Outlook合併多個資料夾並刪除重複項目

使用VBA代碼合併兩個資料夾且不包含重複項目

要將兩個資料夾合併為一個並刪除重複項目，您可以按照以下步驟使用VBA代碼來處理：

1. 按下「Alt + F11」鍵打開「Microsoft Visual Basic for Applications」窗口。

2. 在左側窗格中雙擊「ThisOutlookSession」，然後將以下代碼複製並粘貼到右側的腳本窗口中。

VBA：合併兩個資料夾且不包含重複項目

Sub MergeOutlookFolders_WithoutDuplicates()
'UpdatebyExtendoffice20180521
Dim xSourceFolder As Outlook.Folder
Dim xTargetFolder As Outlook.Folder
Dim xCount, i As Long
Dim xItem As Object
Dim xSourceItem As Object
Dim xTargetItem As Object
Dim xDictionary As Scripting.Dictionary  'Object
Dim xStr As String
On Error Resume Next
Set xDictionary = New Scripting.Dictionary
Set xSourceFolder = Application.Session.PickFolder
Set xTargetFolder = Application.Session.PickFolder
xCount = 0
If xSourceFolder.DefaultItemType <> xTargetFolder.DefaultItemType Then
    MsgBox "Error: The two folders are not in same type!", vbExclamation + vbOKOnly, "Kutools for Outlook"
    Exit Sub
End If
For i = xSourceFolder.Items.Count To 1 Step -1
    Set xSourceItem = xSourceFolder.Items.Item(i)
    xSourceItem.Move xTargetFolder
Next
For i = xTargetFolder.Items.Count To 1 Step -1
    Set xTargetItem = xTargetFolder.Items.Item(i)
    Select Case xTargetItem.Class
        Case olMail
            With xTargetItem
                xStr = .Subject & .Body & .SentOn
            End With
        Case olAppointment
            With xTargetItem
                xStr = .Subject & .Start & .Duration & .Location & .Body
            End With
        Case olContact
            With xTargetItem
                xStr = .FullName & .Email1Address & .Email2Address & .Email3Address
            End With
        Case olTask
            With xTargetItem
                xStr = .Subject & .StartDate & .DueDate & .Body
            End With
    End Select
    If xDictionary.Exists(xStr) = True Then
        xTargetItem.Delete
        xCount = xCount + 1
    Else
        xDictionary.Add xStr, True
    End If
Next i
If xCount <> 0 Then
    MsgBox xCount & " duplicates removed when merging!", vbInformation + vbOKOnly, "Kutools for Outlook"
End If
End Sub

doc merge folders without duplicates 1