【Excel VBA】一瞬でExcelワークシートからOutlookの予定表へスケジュールを登録する

今回はExcelにまとめたスケジュール一覧をOutlookのスケジュール表へ一括登録する方法をご紹介します。



今回の処理方法について

今回のマクロ実行環境はスケジュール一覧があるExcel側となります。実行することで、Excelのスケジュールデータを一件づつ取り出しOutlookの予定表へ登録する流れとなります。

Excelブック(VBA) → 予定表へスケジュールを登録して → Outlook
Excelブック ← スケジュールを登録したよ ← Outlook

次に早速実装をして動かしてみましょう!

Excel VBAからOutlookを操作するための下準備

①まずExcelを起動し、「開発」タブをクリックします。

②VBEの画面が開いたら、メニューから「ツール」>「参照設定」を選択します。

③「Microsoft Outlook XX.X Object Library」を探してチェックボックスにチェックし「OK」をクリックします。

以上です。


VBAを実装する

続いてVBAを実装します。

今回VBAは以下の通りとなります。

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

    'Outlook用の定義
    Dim olApp As Outlook.Application
    Dim olItem  As AppointmentItem
    
    'Excel用の定義
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    
    Dim lnContactCount As Long
    
    'スクリーンの更新は行われません。
    Application.ScreenUpdating = False
    
    'Excelのブックとワークシートのオブジェクトを設定します。
    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets(1)
    
    
    wsSheet.Activate
    
    'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。
    Set olApp = New Outlook.Application
    
    
    '取得結果を記述する行番号を指定します。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)
            
            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)
                
            End With
            
            'ここで保存
            olItem.Save

        Next
    
    Else
        MsgBox "処理を中断します"
    End If
    
    'Null out the variables.
    Set olItem = Nothing
    Set olApp = Nothing
    
            
    'Turn screen updating back on.
    Application.ScreenUpdating = True
    
    MsgBox "Outlook予定表の登録が完了しました!", vbInformation
    
End Sub

実装手順は以下の通りです。今回はExcel側にこのVBAを実装します。
①Excelを新規に開き、「開発」タブをクリックし、「VisualBasic」をクリックします。
もしくはショートカットキー「Alt」+「F11」でもOKです。

②標準モジュールを追加します。
左ペインのVBAProjectを右クリックし、「挿入」、「標準モジュール」を選択します。

③右ペインのウインドウに上記のマクロを入力します。

こちらで完了です。


VBAを実行する

①データを準備します。
サンプルでは前回取得したデータを元に、「開始日時」と「終了日時」に変更を加えています。

手動で入力する際には以下の項目に沿って記入をしてください。
特に「開始日時」と「終了日時」の形式に間違えが内容入力をしてください。

件名 場所 開始日時 終了日時 予定の本文 必須出席者 任意出席者
件名を入力 場所を入力 開始日時を”yyyy/mm/dd hh:mm:ss”形式で入力 終了日時を”yyyy/mm/dd hh:mm:ss”形式で入力 予定の本文を入力 必須出席者のアドレスを入力 任意出席者のアドレスを入力

②「開発」タブの「マクロ」をクリックし「Outlookの予定表へ登録する」を選択し、「実行」をクリックします。

③Outlookの予定表へ登録されたら完成です!

念のためスケジュール表の中身も見てみましょう。
スケジュールの各項目も反映されていますね。

なお、今回は仕様上会議出席者を指定しても出席者へ連絡がされません。
また、2回同じ情報で登録した場合は、既存のスケジュールを変更するのではなく追加となりますのでご注意ください。

2回実施した場合はこうなります。

予定アイテム重複スキップ版追加

予定表の中で、これから登録する件名と開始日時が登録済み予定アイテムと一致していたら
処理をスキップする処理を追加しました。

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 checkFlg As Long
    
    '重複チェックフラグ初期値設定
    checkFlg = 0
    
    
    
    'Excel用の定義
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    
    Dim lnContactCount As Long
    
    'スクリーンの更新は行われません。
    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
    
    '取得結果を記述する行番号を指定します。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)

            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)
                
                '重複チェック
                For Each olItemBefor In olConItems
                    If TypeName(olItemBefor) = "AppointmentItem" Then
                        '登録されている予定表の件名と開始日時が一致していたらフラグを1にする
                        If olItemBefor.Subject = .Subject And olItemBefor.Start = .Start Then
                          checkFlg = 1
                        End If
                    End If
                    
                Next

                If checkFlg <> 1 Then
                    'ここで保存
                    olItem.Save
                    
                End If

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

        Next
    
    Else
        MsgBox "処理を中断します"
    End If
    
    'Null out the variables.
    Set olItem = Nothing
    Set olApp = Nothing
    
            
    'Turn screen updating back on.
    Application.ScreenUpdating = True
    
    MsgBox "Outlook予定表の登録が完了しました!", vbInformation
    
End Sub



予定アイテム重複スキップ&既存予定アイテム更新機能追加

予定表の更新をエクセルからできるようにしました。

新規登録の場合はOutlook予定表に登録され、エクセルのI列に予定アイテムのIDが登録されます。
更新の場合はその予定アイテムのIDと一致した場合に実施されるようにしました。

なお、タイトル、開始日、終了日が変更された場合のみ更新という条件となっていますので、
出席者や本文など変更した場合も更新したい場合は

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

こちらのif文の条件を緩和してください。

なお、if文を外すと問答無用にエクセルリスト分の予定アイテムが更新されますのでご注意ください。

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 checkFlg As Long
    
    '重複チェックフラグ初期値設定
    checkFlg = 0
    
    
    
    'Excel用の定義
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    
    Dim lnContactCount As Long
    
    'スクリーンの更新は行われません。
    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
    
    '取得結果を記述する行番号を指定します。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
                    
                        'エクセルI列の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
                        
                            '登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新
                            '※更新の条件はご都合に応じて変更してください。この条件が無い場合はエクセルの予定表すべて更新されますので、ご注意ください。
                            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
                            
                                'Null out the variables.
                                Set olItem = Nothing
                            
                        End If
                    

                    End If
                    
                Next

                If checkFlg <> 1 Then
                    'エクセルI列のEntryIDと登録されているEntryIDが一致していなかったら新規登録
                    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

                   'エクセルI列へ発行されたEntryIDを書き込み
                   Cells(i, 9) = olItem.EntryID
                    
                End If

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

        Next
    
    Else
        MsgBox "処理を中断します"
    End If
    
    'Null out the variables.
    Set olItem = Nothing
    Set olApp = Nothing
    
            
    'Turn screen updating back on.
    Application.ScreenUpdating = True
    
    MsgBox "Outlook予定表の登録が完了しました!", vbInformation
    
End Sub



さいごに

いかがでしょうか。
Outlookの操作は手作業が多いですからなるべく自動化して効率化を図りたいですね。

他人のOutlook予定表をExcelワークシートへ取り込む方法

【Excel VBA】Outlookの他人の予定表をExcelワークシートへ取り込む

Excelの予定一覧から他人のOutlook予定表を登録、編集する方法

【Excel VBA】他人のOutlook予定表をExcelから登録、編集する

4 件のコメント

  • お世話になります。
    重複した場合の設定などご教示いただけませんでしょうか?
    例えばその場合は作業を停止するなど

    • いつもご利用ありがとうございます。

      重複した場合の設定についてですが、重複フラグを設け、
      予定表の件名と開始日時が一致していたらフラグを1にし、
      その場合は予定表の登録をスキップする処理にしてみました。
      また、記事本文にも追記させ頂きました。

      ご査収の程お願いいたします。

      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 checkFlg As Long

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

      ‘Excel用の定義
      Dim wbBook As Workbook
      Dim wsSheet As Worksheet

      Dim lnContactCount As Long

      ‘スクリーンの更新は行われません。
      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

      ‘取得結果を記述する行番号を指定します。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)

      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)

      ‘重複チェック
      For Each olItemBefor In olConItems
      If TypeName(olItemBefor) = “AppointmentItem” Then
      ‘登録されている予定表の件名と開始日時が一致していたらフラグを1にする
      If olItemBefor.Subject = .Subject And olItemBefor.Start = .Start Then
      checkFlg = 1
      End If
      End If

      Next

      If checkFlg <> 1 Then
      ‘ここで保存
      olItem.Save

      End If

      End With

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

      Next

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

      ‘Null out the variables.
      Set olItem = Nothing
      Set olApp = Nothing

      ‘Turn screen updating back on.
      Application.ScreenUpdating = True

      MsgBox “Outlook予定表の登録が完了しました!”, vbInformation

      End Sub

  • 本日、はじめ活用させていただいたところ、Outlookにしっかり反映されました!
    ありがとうございます。

    一つ質問なのですが、会議日時が変更になった際、前の会議設定を消して、新たな会議設定を入れる(連動させる)ことは可能でしょうか?

    • いつもご利用ありがとうございます。

      一度登録した会議設定を更新(連動)することは可能です。

      会議設定をするとOutlook側ではその会議に対してID(EntryIDと呼ばれます)が発行されますので、
      更新の際はそのIDを手掛かりに会議設定をおこなうという流れとなります。

      以下のマクロは本文のエクセルのリストから会議設定を行うものに対して、エクセルのI列に新規会議の場合はIDをI列に追記、更新の場合はI列のIDをみて該当するIDの会議設定を行うように処理を加えたものです。

      一度サンプルで新規登録から変更(タイトル、開始日、終了日)まで試していただければと存じます。

      なお出席者や本文単体の更新はできませんが、変更したい場合は以下のif文の条件を緩和してみてください。
      If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then

      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 checkFlg As Long

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

      ‘Excel用の定義
      Dim wbBook As Workbook
      Dim wsSheet As Worksheet

      Dim lnContactCount As Long

      ‘スクリーンの更新は行われません。
      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

      ‘取得結果を記述する行番号を指定します。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

      ‘エクセルI列の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

      ‘登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新
      ‘※更新の条件はご都合に応じて変更してください。この条件が無い場合はエクセルの予定表すべて更新されますので、ご注意ください。
      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

      ‘Null out the variables.
      Set olItem = Nothing

      End If

      End If

      Next

      If checkFlg 1 Then
      ‘エクセルI列のEntryIDと登録されているEntryIDが一致していなかったら新規登録
      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

      ‘エクセルI列へ発行されたEntryIDを書き込み
      Cells(i, 9) = olItem.EntryID

      End If

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

      Next

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

      ‘Null out the variables.
      Set olItem = Nothing
      Set olApp = Nothing

      ‘Turn screen updating back on.
      Application.ScreenUpdating = True

      MsgBox “Outlook予定表の登録が完了しました!”, vbInformation

      End Sub

      ご査収の程、お願いいたします。

  • コメントを残す

    メールアドレスが公開されることはありません。 * が付いている欄は必須項目です