2020.11.13 Excel VBA タカヒロ@extan

【Excel VBA】複数ユーザのOutlook予定表をExcelから登録・編集する方法！

複数ユーザのOutlookの予定表の予定をまとめて編集したいことはないでしょうか。

そんな中で、

・Outlookから予定を入れるのは面倒…
・Excelにメンバの予定をまとめ、Outlookへ一括登録をする方法ってあるの？

と悩むことがあるかとおもいます。

今回は、そんなお悩みを解決する、
Excel VBAで複数ユーザのOutlook予定表をExcelから登録、編集する方法について
まとめます！

複数ユーザのOutlook予定表をExcelから追加・編集する方法について

前回、「【Excel VBA】一瞬でExcelワークシートへOutlookの予定表を取り込む方法」をご紹介しましたが、

読者の方から複数ユーザのOutlook予定情報をまとめて編集できないかと

ご要望がありましたので、その操作ができるように機能を変更してみました。

タカヒロ

複数名のスケジュール調整がExcelの1シートで管理できますのでかなり便利です。

では機能の説明をしたいと思います。

今回のVBAの実装先は、これまでと同様Excelブック側となります。

データについてはこれまで１ユーザのみを対象にしていましたが、今回はメールアドレス欄を用意し、そのメールアドレスに該当する複数ユーザを対象にしています。

その対象ユーザに対してExcelからスケジュールの新規登録、変更を行うといった内容となります。

①Excelブック(VBA) →　このメアドの人の予定を編集してね　→ Outlook
②Excelブック ←　メアドの人の予定を変更したよ　← Outlook
③①に戻りメンバリスト件数分処理を繰り返す

では早速実装をして動かしてみましょう！

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

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

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

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

以上です。

VBAを実装する

続いてVBAを実装します。

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

VBAは前回の「【Excel VBA】他人のOutlook予定表をExcelから登録、編集する」をベースに、

複数ユーザ分の編集ができるように機能を追加・変更したものとなります。

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 
  
    Dim strAddress As String 
     
     
    'Excel用の定義 
    Dim wbBook As Workbook 
    Dim wsSheet As Worksheet 
     
    Dim lnContactCount As Long 
     
    'スクリーンの更新は行われません。 
    Application.ScreenUpdating = False 
     
    'Excelのブックとワークシートのオブジェクトを設定します。 
    Set wbBook = ThisWorkbook 
    Set wsSheet1 = wbBook.Worksheets(1) 
     
  
    '操作対象の他人のアドレスを指定 
    strAddress = wsSheet1.Cells(2, 11) 
  
  
     
    'Outlookオブジェクトを設定し、MAPI名前空間を介してOutlookの予定表を取得します。 
    Set olApp = New Outlook.Application 
    Set olNamespace = olApp.GetNamespace("MAPI") 
    Set recOther = olNamespace.CreateRecipient(strAddress) 
    Set olFolder = olNamespace.GetSharedDefaultFolder(recOther, 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 = olConItems.Add() 
  
            'もし違うアドレスだったら再セットする。 
            If strAddress <> wsSheet1.Cells(i, 11) Then 
                '操作対象の他人のアドレスを再指定 
                strAddress = wsSheet1.Cells(i, 11) 
                Set recOther = olNamespace.CreateRecipient(strAddress) 
                Set olFolder = olNamespace.GetSharedDefaultFolder(recOther, olFolderCalendar) 
                Set olConItems = olFolder.Items 
            End If 
                 
                '更新処理 
                For Each olItemBefor In olConItems 
                    If TypeName(olItemBefor) = "AppointmentItem" Then 
                     
                        'エクセルI列のEntryIDと登録されているEntryIDが一致していたら該当予定表を更新 
                        If olItemBefor.EntryID = wsSheet1.Cells(i, 9) Then 
                         
                            '比較用に一時的に作成 
                            With olItem 
                                .Subject = wsSheet1.Cells(i, 1) 
                                .Start = Format(wsSheet1.Cells(i, 3), "yyyy/mm/dd hh:mm:ss") 
                                .End = Format(wsSheet1.Cells(i, 4), "yyyy/mm/dd hh:mm:ss") 
                            End With 
  
  
                            '登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新 
                            '※更新の条件はご都合に応じて変更してください。この条件が無い場合はエクセルの予定表すべて更新されますので、ご注意ください。 
                            If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then 
  
  
                            Else 
                                '定期的な予定である場合は除外 
                                If wsSheet1.Cells(i, 10) <> "True" Then 
                                     With olItemBefor 
                                        .Subject = wsSheet1.Cells(i, 1) 
                                        .Location = wsSheet1.Cells(i, 2) 
                                        .Start = Format(wsSheet1.Cells(i, 3), "yyyy/mm/dd hh:mm:ss") 
                                        .End = Format(wsSheet1.Cells(i, 4), "yyyy/mm/dd hh:mm:ss") 
                                        .Body = wsSheet1.Cells(i, 5) 
                                        .RequiredAttendees = wsSheet1.Cells(i, 6) 
                                        .OptionalAttendees = wsSheet1.Cells(i, 7) 
                                        .Save 
                                    End With 
                                End If 
                            End If 
                             
                                'Null out the variables. 
                                Set olItem = Nothing 
                             
                        End If 
                     
  
                    End If 
                     
                Next 
  
                If wsSheet1.Cells(i, 9) = "" Then 
                    'エクセルI列のEntryIDが登録されていなかったら新規登録 
                    With olItem 
         
                        .Subject = wsSheet1.Cells(i, 1) 
                        .Location = wsSheet1.Cells(i, 2) 
                        .Start = Format(wsSheet1.Cells(i, 3), "yyyy/mm/dd hh:mm:ss") 
                        .End = Format(wsSheet1.Cells(i, 4), "yyyy/mm/dd hh:mm:ss") 
                        .Body = wsSheet1.Cells(i, 5) 
                        .RequiredAttendees = wsSheet1.Cells(i, 6) 
                        .OptionalAttendees = wsSheet1.Cells(i, 7) 
                        .Save 
                   End With 
  
                   'エクセルI列へ発行されたEntryIDを書き込み 
                   wsSheet1.Cells(i, 9) = olItem.EntryID 
                     
                End If 

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

実装手順は以下の通りです。

今回はExcel側にこのVBAを実装します。

①Excelを新規に開き、「開発」タブをクリックし、「VisualBasic」をクリックします。
もしくはショートカットキー「Alt」＋「F11」でもOKです。

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