スキルアップ・問題解決なら、モーグにおまかせ！

Outlookの予定表をExcelを使って、削除、登録させるようにしたいです
 
下記コードは先日ネットで見つけたものです
対象予定表12か月分について
EntryIDが一致したときに更新
EntryIDがないときは登録
となっているかと思います。
 
こちらを、
EntryIDが一致したときに削除
EntryIDがないときは登録
とするにはどのようにしたらよろしいでしょうか。
https://ja.stackoverflow.com/questions/23493/outlook%e3%81%aevba%e3%81%a7%e4%ba%88%e5%ae%9a%e8%a1%a8%e5%89%8a%e9%99%a4%e3%81%8c%e3%81%95%e3%82%8c%e3%81%aa%e3%81%84#:~:text=Outlook%E3%81%AE
↑こちらを参考に何度か試してみましたが上手くいきません
 
よろしくお願いします
 
 
[Sub 参考()
 
    'Outlook用の定義
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Folder
    Dim olConItems As Outlook.Items
    Dim olItem As AppointmentItem
    Dim olItemBefor As AppointmentItem
    Dim checkFlg As Long
     
    '重複チェックフラグ初期値設定
    checkFlg = 0
 
    'Excel用の定義
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim lnContactCount As Long
    Dim i As Long
     
    '抽出期間の定義
    Dim strStart As String
    Dim strEnd As String
    Dim intKikan As Integer
     
     
    '対象予定表の抽出期間を月単位で指定します。
    '※抽出期間が短いと予定アイテムのチェックができず登録できない場合がありますので注意してください｡
    intKikan = 12 '抽出期間を12か月にしています。
     
    strStart = Format(DateAdd("m", -intKikan, Date), "yyyy/mm/dd") '抽出するスケジュールの開始日を指定
    strEnd = Format(DateAdd("m", intKikan, Date), "yyyy/mm/dd") '抽出するスケジュールの終了日を指定
     
     
    'スクリーンの更新は行われません。
    Application.ScreenUpdating = False
     
    'Excelのブックとワークシートのオブジェクトを設定します。
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets(1)
     
    wsSheet.Activate
     
    'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar)
    Set olConItems = olFolder.Items
 
    'Restrictメソッドで期間指定して抽出するメールアイテムを絞り込む
    Set olConItems = olConItems.Restrict("[Start] >= '" & strStart & "' And [End] < '" & strEnd & "'")
 
 
    '取得結果を記述する行番号を指定します。2行目のセルから開始されることになります。
    lnContactCount = 2
 
    Dim rc As Integer
    rc = MsgBox("予定表へ登録しますか？", vbYesNo + vbQuestion, "確認")
     
    If rc = vbYes Then
     
        '予定表一覧の件数分繰り返す。
        For i = lnContactCount To Cells(1, 1).End(xlDown).Row
            Set olItem = olApp.CreateItem(olAppointmentItem)
 
            '重複チェック＆更新処理
            For Each olItemBefor In olConItems
                If TypeName(olItemBefor) = "AppointmentItem" Then
                 
                    'ExcelI列のEntryIDと登録されているEntryIDが一致していたら該当予定表を更新
                    If olItemBefor.EntryID = Cells(i, 9) Then
                     
                        '比較用に一時的に作成
                        With olItem
                            .Subject = Cells(i, 1)
                            .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
                            .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
                        End With
     
                     
                        '重複フラグ1をセット
                         checkFlg = 1
                     
                        '登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新
                        '※更新の条件はご都合に応じて変更してください。この条件が無い場合はExcelの予定表すべて更新されますので、ご注意ください。
                        If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then
     
     
                        Else
 
                            '定期アイテムは除外します。
                            If Not olItemBefor.IsRecurring Then
                                 With olItemBefor
                                    .Subject = Cells(i, 1)
                                    .Location = Cells(i, 2)
                                    .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
                                    .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
                                    .Body = Cells(i, 5)
                                    .RequiredAttendees = Cells(i, 6)
                                    .OptionalAttendees = Cells(i, 7)
                                    .Save
                                End With
                            End If
                        End If
                         
                        'Null out the variables.
                        Set olItem = Nothing
                         
                    End If
                End If
            Next
            'EntryIDが空である場合のみ新規登録をすることにしました。
            If checkFlg <> 1 And Cells(i, 9) = "" Then
                With olItem
                    .Subject = Cells(i, 1)
                    .Location = Cells(i, 2)
                    .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
                    .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
                    .Body = Cells(i, 5)
                    .RequiredAttendees = Cells(i, 6)
                    .OptionalAttendees = Cells(i, 7)
                    .Save
               End With
     
               'ExcelI列へ発行されたEntryIDを書き込み
               Cells(i, 9) = olItem.EntryID
                 
            End If
     
         
        '重複フラグリセット
        checkFlg = 0
     
    Next
     
    Else
        MsgBox "処理を中断します"
        Exit Sub
    End If
     
    'Null out the variables.
    Set olItem = Nothing
    Set olApp = Nothing
    Set wbBook = Nothing
    Set wsSheet = Nothing
    Set olNamespace = Nothing
    Set olFolder = Nothing
    Set olConItems = Nothing
 
             
    'Turn screen updating back on.
    Application.ScreenUpdating = True
     
    MsgBox "Outlook予定表の登録が完了しました！", vbInformation
     
End Sub][/code]

予定を管理するAppointmentItem オブジェクトのヘルプは下記のようです。
https://learn.microsoft.com/ja-jp/office/vba/api/outlook.appointmentitem
これには、削除するための Deleteメソッドが用意されていますので、
これを利用したらいかがですか？
 
# 私はこれ以上の情報を持ち合わせませんので、以上とさせていただきます。

引用:
下記コードは先日ネットで見つけたものです

引用:
↑こちらを参考に何度か試してみましたが上手くいきません

（追記）
＞コードがどんな条件でどんな動作を行っているかは把握していますか？
Suzu様の求めるレベルではないかもしれませんが
 
前後12か月について
EntryIDがある場合→EntryIDが一致したら更新
EntryIDがない場合→新規追加
となっているかと思います
 

引用:
If olItemBefor.EntryID = Cells(i, 9) Then
　　　　　olItemBefor.Delete

引用:
If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then
  
               Else
                  With olItemBefor
                       .Subject = Cells(i, 1)
                       .Location = Cells(i, 2)
                       .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
                       .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
                       .Body = Cells(i, 5)
                       .RequiredAttendees = Cells(i, 6)
                       .OptionalAttendees = Cells(i, 7)
                       .Save
                   End With
       End If

技術的観点から、Microsoftのヘルプを紹介しましたが、別の観点から。
 
予定表は、期間が過ぎてもヒストリーとして残すことが多く、
保持していても害を及ぼすことは少ないものと思います。
ですから、IDを指定してまで削除する必要はなく、
普通は、一定期間（数年）が過ぎた段階で予定表を消すことが多いと思います。
このように頻度も低い訳ですから、手動で削除実行することを推奨します。
 
引用されたコードの出所も明記すべきです。
https://extan.jp/?p=1693#google_vignette
でしょうけど、そこで削除を扱っていないのも、そうした理由があるものと思料します。
 
【手動削除の方法】
・「表示」ー「ビューの変更」で「一覧」にすれば表形式の表示になります。
・削除したいところを、ShiftキーやCtrlキーを併用しながら選択し
  (Excelのシートとほぼ同等の操作です）
削除すればよいのではないですか？
 
手動のほうが自覚的な操作ですから、誤操作によるリスクも低く、
手間もかからず、確実なはずです。
あえてマクロで削除する必要もないと思います。
-----
ちなみに、
> sheetにある情報すべて（抽出期間外も）削除、追加となってしまいました
とのことですが、抽出対象を絞り込んでいるのは、

Set olConItems = olConItems.Restrict("[Start] >= '" & strStart & "' And [End] < '" & strEnd & "'")

 simple　様
 
見たネットはどこかわからなくなったのでリンク先をのせられませんでした
私の見たものとは違うけどこちらにもあったのですね
 
しかも色々とあるので拝見させてもらいます
 
予定表が度々変更があるのと
変更箇所が多数、何台もPCがあるので手動だと時間を要してしまいます
また、間違うこともあったりで
 
簡便的に正確に変更方法を模索してマクロにいきつきました
 
 simple様せっかく色々と教えていただきましたが
マクロでできればと思っております
ごめんなさい
 
あまりマクロ詳しくないので初歩的な質問だったりするかもしれませんが
もし分かりましたら教えてください
 
よろしくお願いいたします。
 
ステップ実行でsimple様が指摘の箇所が黄色くなるのですが
ここからどうしていいのか分かりません
 
 
 
 
 
 

引用:
前後12か月について
EntryIDがある場合→EntryIDが一致したら更新
EntryIDがない場合→新規追加
となっているかと思います

直接の回答ではありません。直接の原因は、他の方の回答を参考にしてください
 
提示されたコード。このコードはプロシージャひとつにすべてを詰め込んでいます。
これでは、可読性が下がり、デバックが困難になり、原因追及も困難になります。
 
ひとつに詰め込んでいるため
・156行。
・1行の長さが最大145桁
・インデントが深い。最大10
・変数 15個
これでは、可読性か大幅に下がり、原因追及・デバックは困難ではありませんか
 
プログラムの原則に『単一責任の原則』があります。ここでの意味はプロシージャは一つの責任だけを持つ。となります。プロシージャは複数の役割は与えず、単一機能のみ。一つの仕事だけにする。という意味です。
 
今回のケース。要求から考えられる仕様は
・ユーザーへ確認
・指定IDの有無チェック
・指定IDを削除
・指定IDの登録
・指定IDの更新
と行ったところでしょうか。
 
たとえば、下記の行、コードとしては正しいのでしょうが、内容をすぐに理解出来るのでしょうか。
そして、実際のデバック時、条件が3つあり、ネストも非常に深く、このコードでデバック時にバグを見つけ出せるのでしょうか。

                        If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then

                        Else
                            '定期アイテムは除外します。
                            '<略>
                        End If

Function CheckMailItem(olItemBefor As AppointmentItem, olItem As AppointmentItem)
    Dim b As Boolean
    b = True
    b = b And (olItemBefor.Subject = olItem.Subject)
    b = b And (olItemBefor.Start = olItem.Start)
    b = b And (olItemBefor.End = olItem.End)
    CheckMailItem = b
End Function

    Dim b As Boolean
    b = CheckMailItem(olItemBefor, olItem)
    If b Then
        Debug.Print "条件OK", olItemBefor.Subject
    Else
        Debug.Print "定期アイテムは除外", olItemBefor.Subject
    End If

Sub DeleteMailItem(olItemBefor As AppointmentItem, i As Long)
    '定期アイテムは除外します。
    If Not olItemBefor.IsRecurring Then
         With olItemBefor
            .Subject = Cells(i, 1)
            .Location = Cells(i, 2)
            .Start = Format(Cells(i, 3), "yyyy/mm/dd hh:mm:ss")
            .End = Format(Cells(i, 4), "yyyy/mm/dd hh:mm:ss")
            .Body = Cells(i, 5)
            .RequiredAttendees = Cells(i, 6)
            .OptionalAttendees = Cells(i, 7)
            .Save
        End With
    End If
End Sub

    Dim b As Boolean
    b = CheckMailItem(olItemBefor, olItem)
    If b Then
        Debug.Print "条件OK", olItemBefor.Subject
    Else
        Debug.Print "定期アイテムは除外", olItemBefor.Subject
        DeleteMailItem olItemBefor, i
    End If

    Dim rc As Integer
    rc = MsgBox("予定表へ登録しますか？", vbYesNo + vbQuestion, "確認")

    If rc = vbYes Then

       '予定表一覧の件数分繰り返す。
        For i = lnContactCount To Cells(1, 1).End(xlDown).Row
            Set olItem = olApp.CreateItem(olAppointmentItem)
            ' <以下略>

    Dim rc As Integer
    rc = MsgBox("予定表へ登録しますか？", vbYesNo + vbQuestion, "確認")

    If rc = vbYes Then
        UpdateOutlookPlan 引数
    End If

Sub UpdateOutlookPlan(引数)

    '予定表一覧の件数分繰り返す。
    For i = lnContactCount To Cells(1, 1).End(xlDown).Row
        Set olItem = olApp.CreateItem(olAppointmentItem)
        ' <以下略>
End Sub

Suzu　様
 
質問を勘違いしまして、すいません
コードも理解できてませんでした
丁寧に説明していただきありがとうございます
 
 ＞'strStart と、strEnd それぞれに対し シート3列目、4列目 のデータと比較し
 ＞'データを生成するか決める必要があります。
 
分からないので教えてもらいたいのですが
下記コード↓の部分を「Subject、Start、End が一致していない」を削除して
「strStart と、strEnd それぞれに対し シート3列目、4列目 のデータと比較」一致したら
と修正したらよいのでしょうか。
 
また「strStart と、strEnd それぞれに対し シート3列目、4列目 のデータと比較」というのは
「EntryIDと登録されているEntryIDが一致」と同じように作成したら大丈夫ということでしょうか
 
 

引用:
If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then

前提条件として

引用:
EntryIDが一致したときに削除
EntryIDがないときは登録

引用:
　sheetにある情報すべて（抽出期間外も）削除、追加となってしまいました

MMYS 様
 
全部はまだ理解できていませんが
ひとつひとつ作ってみようと思います
 
また分からないことがあったら教えてください
ありがとうございました