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

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

そんな中で、

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

今回は、そんなお悩みを解決する、

についてまとめます！

複数ユーザの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 
                     
                        'ExcelI列の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 
  
  
                            '登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新 
                            '※更新の条件はご都合に応じて変更してください。この条件が無い場合はExcelの予定表すべて更新されますので、ご注意ください。 
                            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 
                    'ExcelI列の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 
  
                   'ExcelI列へ発行された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を右クリックし、「挿入」、「標準モジュール」を選択します。

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

こちらで完了です。

テストデータを準備する

対象者のメールアドレスと予定をExcelへまとめる

今回のマクロはExcel側にまとめた予定表取得対象者のメールアドレスを対象に予定表を登録、編集する処理となるため、

Excel側に対象者のメールアドレスとスケジュールをまとめる必要があります。

K列に対象者のメールアドレス、A列からJ列までスケジュールを入力します。
※「EntryID」は空欄で構いません。

入力が面倒という方は、前回の「【Excel VBA】一瞬で複数ユーザのOutlook予定表をExcelへ取り込む方法！」を参考に既存のスケジュールを取り込むようにしてください。
この場合は既存の予定の変更という形で処理されます。

サンプルでは、既存の予定の変更の形で、以下の予定を、

のようにスケジュールを変更しています。

タカヒロ

今回は既存予定を変更する処理となりますので、テストユーザ等で十分に検証してから本番稼働させるようにお願いします。

なお、予定表取得対象者のメールアドレスですが、同じドメインに参加しているユーザのメールアドレスで
マクロを実行する人は対象者の予定が変更できる権限を保持している必要がありますので、ご注意ください。

こちらで、テストデータの準備は完了です。

VBAを実行する

ExcelからOutlook予定表の単体の予定を変更する

では早速VBAの実行をしてみましょう。

①「開発」タブの「VBA」をクリックし「複数の他人のOutlook予定表へ予定を登録する」を選択し、「実行」をクリックします。

②「Outlook予定表の取り込みが完了しました！」が表示されたら完了です。

Outlook予定表がExcelの指定通りに変更されたことが確認できましたね！

変更前

変更後

さいごに

いかがでしょうか。

今回は

についてまとめました。

なお、既存の予定を変更する処理が含まれますので、検証は十分されてから本番稼働するようあらためてお願いいたします。

また、他にも便利な方法がりますので、よろしければご参照頂ければと思います。

Excelの予定一覧から自分のOutlookの予定表へ登録する方法

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

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

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