【VBA】ExcelからOutlookの追加した予定表へスケジュールを登録する

Outlookの予定表で既定の予定表に追加した予定表へスケジュールを一括で登録したいときはないでしょうか。

けど、そんな時に困ることは、

・VBAで追加した予定表へ予定を登録する方法はない?
・ExcelでまとめたスケジュールをOutlookに一括登録するにはどうすればよい?

だと思います。

今回は、そんな困りごとを解決する、
Excelにまとめたスケジュール一覧をOutlookの追加した予定表へ一括登録する方法について
まとめます!



Excelにまとめたスケジュール一覧をOutlookの予定表へ一括登録する機能ついて

以前、「【Excel VBA】一瞬で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は以下の通りとなります。
前回の記事「【Excel VBA】一瞬でExcelワークシートからOutlookの予定表へスケジュールを登録する」の最終バージョンである高速登録版をベースに、
変更を加えたものになります。

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
    
    '追加した予定表の異動時に使用するオブジェクト
    Dim olItemMove As Object
    
    '重複チェックフラグ初期値設定
    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).Folders("追加予定表1")
    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
                
                    'エクセル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

                            '定期アイテムは除外します。
                            If Cells(i, 10) <> "True" 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, 7)
                                    .OptionalAttendees = Cells(i, 8)
                                    .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, 7)
                    .OptionalAttendees = Cells(i, 8)
               End With
               
               '追加した予定表へアイテムを移動します。
               Set olItemMove = olItem.Move(olFolder)

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

               
            End If
    
        
        '重複フラグリセット
        checkFlg = 0
    
    Next
    
    Else
        MsgBox "処理を中断します"
    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

設定してもらいたい箇所は以下の<追加予定表を指定>の箇所です。

追加予定表の表示名を入れるようにしてください。

Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar).Folders(“<追加予定表を指定>“)

サンプルでは「追加予定表1」を指定しています。

予定表の表示名は、左ペインの個人の予定表のリストか、

フォルダ」タブをクリックし、リボンメニューの「予定表のプロパティ」から確認することができます。

タカヒロ
タカヒロ
Folderオブジェクトの表示名の部分に数字を入れるとインデックス値となります。
例えば「1」と設定した場合は、1番目の追加した予定表を参照する形となります。

Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar).Folders(1)

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

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

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

こちらで完了です。


VBAを実行する

①データを準備します。
サンプルではA列に件名、C、D列に開始日時、終了日時、K列に追加した予定表名を入れています。

手動で入力する際には以下の項目に沿って記入をしてください。

タカヒロ
タカヒロ
「開始日時」と「終了日時」以外は空欄でも構いません。

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

タカヒロ
タカヒロ
既に追加した予定表へ予定が登録されている場合は、
以下の手順を参照頂くと、データ出力できるのでサンプルが楽に準備できます。

【VBA】ExcelへOutlookの追加予定表の予定情報を取り込む方法

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

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

別の追加した予定表へ登録する

次に別の追加した予定表へ登録をしてみましょう。
2つ目に追加した予定表の表示名は「追加予定表2」ですので、以下のFoldersオブジェクトの引数に”追加予定表2″と入力します。

Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar).Folders(“追加予定表2“)

タカヒロ
タカヒロ
「追加予定表1」の時のデータを流用する場合、
I列に「EntryID」が入っている場合は削除をするようにお願いします。

では実行してみましょう。

はい、2つ目の追加予定表へ予定が登録できましたね。



今回のVBAについて説明

これまですべての期間を対象にチェックをして登録をしていたので、処理時間がかかってしまいがちでしたが、
対象期間を設け、期間を絞ることによりチェック対象の件数が少なくなるので処理時間を短くすることができました。
サンプルでは抽出期間を12か月にしています。
intKikan = 12

抽出するスケジュールの開始日を指定します。
strStart = Format(DateAdd(“m”, -intKikan, Date), “yyyy/mm/dd”)

抽出するスケジュールの終了日を指定します。
strEnd = Format(DateAdd(“m”, intKikan, Date), “yyyy/mm/dd”) ‘

取得したOutlookオブジェクトを取得します。
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace(“MAPI”)

予定表のリストはolFolderCalendarというメンバーに格納されていますのでそれを指定しています。
追加した予定表はそのフォルダごとに分かれて格納されていますので、
追加した予定表の表示名をFoldersオブジェクトの引数に渡すことにより
追加した予定表のオブジェクトを取得することができます。
Set olFolder = olNamespace.GetDefaultFolder(olFolderCalendar).Folders(“追加予定表2”)

エクセルI列のEntryIDと登録されているEntryIDが一致していたら該当予定表を更新します。
If olItemBefor.EntryID = Cells(i, 9) Then

登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新します。
※更新の条件はご都合に応じて変更してください。この条件が無い場合はエクセルの予定表すべて更新されますので、ご注意ください。
If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then

定期的な予定でない場合変更します。
If Cells(i, 10) = “False” Then

Excel側の値を読み込み、予定オブジェクトにセットします。
.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

エクセルI列のEntryIDと登録されているEntryIDが一致していなかったら新規登録します。
If checkFlg <> 1 Then

今回追加した処理になります。
Moveメソッドで追加した予定表へアイテムを移動しolItemMoveへセットします。
Set olItemMove = olItem.Move(olFolder)

タカヒロ
タカヒロ
なお、新規の場合、Saveメソッドがない理由は、Moveメソッドで移動した段階で、
追加した予定表へ保存されるようなので、Saveは省略しました。
気になるようでしたら、Saveメソッドを入れておいてもよいかもしれません。

新規の場合は発行されたEntryIDをExcelシートのI列へ書き込みます。
Cells(i, 9) = olItem.EntryID



さいごに

いかがでしょうか。

今回は、
Excelにまとめたスケジュール一覧をOutlookの追加した予定表へ一括登録する方法について
まとめました。

他にもOutlook関連の操作をまとめていますので、よろしければご覧ください。

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

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

【Excel VBA】先月、今月、翌月分のOutlook予定表データをワンクリックで取り込む

コメントを残す

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