Excelからoutlookへ予定を登録する

Question

皆さまご教示ください。
Excelからoutlookへ予定登録をする中で、下記マクロ/VBAを調整中です。
別シートより予定や終日予定を関数で読み込んでおり空白があると上手く登録できません。
（下記画像を参照ください）

outlookへ登録するための予定表

outlookへ登録するためのbook（関数表示ver)

【件名】に空白がある場合、エラーを吐いてしまいます。

【件名】が空白の場合はスキップする（関数が含まれていても無視する）など挿入することは可能でしょうか？

まだマクロ/VBAを始めたばかりなのでご教示いただけると幸いです。
下記、設定している構文です。

Sub Outlookの予定表へ終日の予定を登録する()

'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
Dim i As Integer


'重複チェックフラグ初期値設定
checkFlg = 0

'Excel用の定義
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lnContactCount 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).Value, "yyyy/mm/dd hh:mm:ss")
                                .End = Format(Cells(i, 4).Value, "yyyy/mm/dd hh:mm:ss")
                                .Body = Cells(i, 5)
                                .RequiredAttendees = Cells(i, 7)
                                .OptionalAttendees = Cells(i, 8)
                                '終日の予定であるか指定します。
                                .AllDayEvent = Cells(i, 11)
                                .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).Text, "yyyy/mm/dd hh:mm:ss")
                .End = Format(Cells(i, 4).Text, "yyyy/mm/dd hh:mm:ss")
                .Body = Cells(i, 5)
                .RequiredAttendees = Cells(i, 7)
                .OptionalAttendees = Cells(i, 8)
                '終日の予定であるか指定します。
                .AllDayEvent = Cells(i, 11)
                .Save
           End With
           

           'ExcelI列へ発行されたEntryIDを書き込み
           Cells(i, 9) = olItem.EntryID
           'ExcelF列へ予約者を書き込み
           Cells(i, 6) = olItem.Organizer
            
        End If

    
    '重複フラグリセット
    checkFlg = 0

Next

Else
    MsgBox "処理を中断します"
End If

'オブジェクトを解放します。
Set olItem = Nothing
Set olApp = Nothing
Set wbBook = Nothing
Set wsSheet = Nothing
Set olNamespace = Nothing
Set olFolder = Nothing
Set olConItems = Nothing
Set olItemBefor = Nothing


'スクリーンの更新をオンにします。
Application.ScreenUpdating = True

MsgBox "Outlook予定表の登録が完了しました！", vbInformation

End Sub

足りない情報や、何がしたいのかわかりにくいと思いますが、お力添えいただけると幸いです。

Comments

[Usirow]

そのエラーを吐いてしまうところの If checkFlg <> 1 And Cells(i, 9) = "" Then を、If checkFlg <> 1 And Cells(i, 9) = "" And Cells(i, 1).Value <> "" Then とするのではダメなのでしょうか？

Answer 1

「件名に空白がある場合」というより「件名が空白=開始日時なども空白」ということではないでしょうか?
そうであれば、

 If checkFlg <> 1 And Cells(i, 9) = "" Then

を

 If checkFlg <> 1 And Cells(i, 9) = "" And Cells(i,1) <> "" Then

とすればよいのではないかと思います。