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 работают в папке календаря, включая все её подпапки.