Outlook：如何移除重複的日曆項目

有時從其他裝置匯入活動時，日曆中可能會出現重複項目。本教學將介紹兩種清除方式：若重複項目較少，可逐一手動刪除；若數量較多，則可透過 VBA 一次全部移除。

手動刪除重複日曆項目（逐一處理）

使用 VBA 刪除重複日曆項目（一次處理）

---

手動刪除重複日曆項目（逐一處理）

若要逐一移除重複的日曆項目，請先將它們依特定順序排列，以便清楚辨識重複項目，再逐一刪除。

1. 日曆預設通常為「日曆」檢視模式。請先啟用您要刪除重複事件的日曆，然後點選「檢視」>「變更檢視」>「清單」。

日曆現已改以清單形式呈現。

2. 接著設定一個條件來判斷哪些項目屬於重複項目，例如比對項目是否具有相同的主旨。在日曆清單中點選「主旨」欄位，所有主旨相同的項目便會自動歸類在一起。

3. 現在您可以逐一右鍵點選主旨相同的項目，並在彈出的快捷功能表中選擇「刪除」，輕鬆移除它們。

---

---

使用 VBA 刪除重複日曆項目（一次處理）

以下介紹幾段 VBA 程式碼，可針對不同情境，一鍵清除日曆資料夾中的所有重複日曆項目。

1. 按下 「Alt」＋「F11」 鍵，立即開啟「Microsoft Visual Basic for Applications」視窗！

2. 點選「插入」>「模組」，建立新的空白模組，然後將下方程式碼複製並貼上至該模組中。

VBA：移除特定分類中的所有重複日曆項目

'Sub RemoveDuplicateCalendar()
'UpdatebyExtendoffice20220413
  Dim xStores As Stores
  Dim xStore As Store
  Dim xRootFolder As Folder
  Dim xFolder As Object
  Set xStores = Application.Session.Stores
  For Each xStore In xStores
    Set xRootFolder = xStore.GetRootFolder
    For Each xFolder In xRootFolder.Folders
      Call ProcessFolders(xFolder)
    Next
  Next
  Set xStores = Nothing
End Sub

Sub ProcessFolders(ByVal CurrentFld As Folder)
  Dim xDictionary As Object
  Dim i As Long
  Dim xItem As Object
  Dim xKey As String
  Dim xSubFld As Folder
  On Error Resume Next
  If CurrentFld.DefaultItemType <> olAppointmentItem Then Exit Sub
  Set xDictionary = CreateObject("Scripting.Dictionary")
  For i = CurrentFld.Items.Count To 1 Step -1
    Set xItem = CurrentFld.Items.Item(i)
    'change categories as you need in below script
    If xItem.Categories = "date" Then
    'change the comparing items as you need
      xKey = xItem.Subject & xItem.Location & xItem.Body & xItem.Categories
      If xDictionary.Exists(xKey) = True Then
        xItem.Delete
      Else
        xDictionary.Add xKey, True
      End If
    End If
  Next i
  For Each xSubFld In CurrentFld.Folders
    ProcessFolders xSubFld
  Next
End Sub

在此 VBA 中，系統會根據主旨、地點、內文與分類進行比對，自動移除「date」分類下的所有重複項目。您可依需求靈活調整這些比對條件。

3. 接著按下「F5」鍵，或點選「執行」來執行程式碼。此時會彈出「巨集」對話方塊，請選擇「RemoveDuplicateCalendar」並點選「執行」。。

此時，「date」分類中的重複項目已成功移除。

VBA：跨分類移除所有重複日曆項目

Sub RemoveDuplicateCalendar()
'UpdatebyExtendoffice20220413
  Dim xStores As Stores
  Dim xStore As Store
  Dim xRootFolder As Folder
  Dim xFolder As Object
  Set xStores = Application.Session.Stores
  For Each xStore In xStores
    Set xRootFolder = xStore.GetRootFolder
    For Each xFolder In xRootFolder.Folders
      Call ProcessFolders(xFolder)
    Next
  Next
  Set xStores = Nothing
End Sub

Sub ProcessFolders(ByVal CurrentFld As Folder)
  Dim xDictionary As Object
  Dim i As Long
  Dim xItem As Object
  Dim xKey As String
  Dim xSubFld As Folder
  On Error Resume Next
  If CurrentFld.DefaultItemType <> olAppointmentItem Then Exit Sub
  Set xDictionary = CreateObject("Scripting.Dictionary")
  For i = CurrentFld.Items.Count To 1 Step -1
    Set xItem = CurrentFld.Items.Item(i)
    'change the comparing items as you need
      xKey = xItem.Subject & xItem.Location & xItem.Body & xItem.Categories
      If xDictionary.Exists(xKey) = True Then
        xItem.Delete
      Else
        xDictionary.Add xKey, True
      End If
  Next i
  For Each xSubFld In CurrentFld.Folders
    ProcessFolders xSubFld
  Next
End Sub

執行此程式碼後，各分類中主旨、地點、內文與分類完全相同的重複項目將一律移除。

注意：上述 VBA 適用於日曆資料夾及其子資料夾。