①Excelブック(VBA) → 予定表へスケジュールを登録して → Outlook
②Excelブック ← スケジュールを登録したよ ← Outlook
まとめてスケジュールを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
Dim i 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 "処理を中断します"
Exit Sub
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
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
'重複チェックフラグ初期値設定
checkFlg = 0
'Excel用の定義
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lnContactCount As Long
Dim i 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 "処理を中断します"
Exit Sub
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
If olItemBefor.Subject = olItem.Subject And olItemBefor.Start = olItem.Start And olItemBefor.End = olItem.End Then
こちらのif文の条件を緩和してください。
なお、if文を外すと問答無用にExcelリスト分の予定アイテムが更新されますのでご注意ください。
VBAは以下の通りとなります。
Sub Outlookの予定表へ登録する_重複スキップ_Excelリストから変更できる版()
'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
'重複チェックフラグ初期値設定
checkFlg = 0
'Excel用の定義
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lnContactCount As Long
Dim i 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
'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
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
'ExcelI列の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
'ExcelI列へ発行されたEntryIDを書き込み
Cells(i, 9) = olItem.EntryID
End If
'重複フラグリセット
checkFlg = 0
Next
Else
MsgBox "処理を中断します"
Exit Sub
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の予定表すべて更新されますので、ご注意ください。
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
.send ←ここに追加
End With
End If
――――――――――――――――――――――――――――――――――――――――
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
‘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 & "'")
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) = “” And Cells(i, 1) “” And Cells(i, 3).Value >= DateSerial(Year(Now), Month(Now) + 1, 0) And Cells(i, 3).Value <= DateSerial(Year(Now), Month(Now) + 2, 0) 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
'オブジェクトを解放します。
Set olItem = Nothing
Set olApp = Nothing
Set wbBook = Nothing
Set wsSheet = Nothing
Set olNamespace = Nothing
Set olFolder = Nothing
Set olConItems = Nothing
Set olItemBefor = Nothing
End Sub
――――――――――――――――――――――――――――――――――――――――
以前ご教示いただいたものを入力かつ、私自身で調べたものを入れて工夫しているのですが上手くいかず・・・
・当月＋翌々月までの予定を登録を満たすのは下記であっているのでしょうか・・？
よろしくお願いいたします。
'EntryIDが空で､かつ開始日が翌月である場合のみ新規登録をします｡
If checkFlg 1 And Cells(i, 9) = “” And Cells(i, 1) “” And Cells(i, 3).Value >= DateSerial(Year(Now), Month(Now) + 1, 0) And Cells(i, 3).Value <= DateSerial(Year(Now), Month(Now) + 2, 0) Then
たびたび失礼いたします。
現在作成中の物は別シートで作成した予定表→outlookへ送り込むシートにまとめております。
現在、エラーが出ておりその原因として予測したのは
①予定がとびとびで途中で入力ができず登録できない？
→要件としては、1/1予定あり 1/2は未定のため空白 1/3予定あり・・・
といった具合の場合、1/1は登録できるものの、1/2でエラーが発生し、1/3以降登録できません。（現状：下記部分でデバッグ」と表示されます）
If checkFlg 1 Then
‘ExcelI列のEntryIDと登録されているEntryIDが一致していなかったら新規登録
With olItem
【VBA】Excel からOutlookの会議出席依頼を送信する方法！会議変更後の送信も対応！
【VBA】Outlook会議通知の重要度を設定する方法！
【Excel VBA】Outlookの他人の予定表をExcelシートへ取り込む方法
【VBA】一瞬で複数ユーザのOutlook予定表をExcelへ取り込む方法！
【VBA】Excelの表をOutlookの予定表へ挿入する方法！画像貼り付けも可！
【Excel VBA】一瞬でExcelワークシートへOutlookの予定表を取り込む方法
【VBA】他人のOutlook予定表へExcelから登録、編集、代理送信する方法
【VBA】Excel からOutlookへ終日の予定を登録する方法！複数日指定も！
本当にとても有益な情報をありがとうございます。
1点どうしても解決したいことがあります。
”【VBA】一瞬でExcelのスケジュールをOutlookの予定表へ登録/変更する方法”
でプログラムをコピペして小生が実装したところ問題なく処理が行えました。
しかしそのプログラムを会社の同僚へアウトルックの添付ファイルで送ったところ
以下のエラーが表示が出まして解決できず困っております。
Microsoft Visual Basic
実行時エラー ’－1248722935(b5920009)’:
同期を取ったこのフォルダーのアイテムが一致しません。重複を解消するには、アイテムを開き、そしてもう一度この操作を行ってみてください。
色々とネット等で調べたのですが、どうしてもわからないです。
同僚ですので、勿論ドメインは同じです。
以上、助けて頂ければとても嬉しく思います。
いつもご利用ありがとうございます。
同僚の方のPCの方で実行エラーが発生する件につきまして、
同期に関する内容ですので、Outlookのデータファイルに何かしらの問題がある可能性があります。
以下のMS公式ドキュメントに関連する記載がございますので、対応内容などご参考ください。
https://learn.microsoft.com/ja-jp/exchange/troubleshoot/client-connectivity/ost-sync-issues
また問題切り分けのため、別の方のPCでも同様の事象が発生するかもご確認のほどお願いいたします。
修正点ご教示いただきありがとうございます。
変更してみましたが、上手くいかず・・・・
処理に、10分程度かかってしまいます。
処理時間がかかる件ですが、抽出期間とアイテム数に応じて時間がかかりますので、
以下の抽出期間を少な目（2、3とか）に設定し、確認頂けますでしょうか。
intKikan = 6 ‘抽出期間を2か月以上にします。
・登録しようとしているデータの詳細（登録できるデータとできないデータ2~3件）
→特に確認したい項目は開始日時、終了日時の日付の部分です。実際に使用した日付データを記載願いします。それ以外の項目はダミーデータで結構です。
→→
件 名：【=入力!H4&””】 入力シートからコピーしてきています
場 所：入力なし
開始日時：【=IF(A2″”,入力!A4,””)】A4には日付情報が入っています
終了日時：【=IFERROR(C2+1,””)】開始日時日付情報に+1（終日日程にするため）
予定の本文：入力なし
予約者：登録完了後に自動でメールの名前が入力されます
必須出席者：【=IF(A2″”,”メールアドレス”,””)】
任意出席者：なし
といった具合です
8/1～9/2までテストデータを入力しており、関数設定は2023年12/31まで入っています（Excelの行500行くらいまで関数が入っています。
10/1と10/2にもテストで予定登録していましたが、実行後反映されておりませんでした。
・エラーの内容（表示されているエラーメッセージ、エラー発生箇所など）
→デバッグしてハイライトされているコードと、表示されているエラー番号をご教示ください。
→→こちらは、登録ボタンを押した後、1,2分程度で完了し特にエラー表示はされません。
ご丁寧にありがとうございます。
よろしくお願いします。
ご連絡ありがとうございます。
以下を確認して再度新規登録ができるかご確認頂けますでしょうか。
①新規登録の際の条件式
■変更前
‘EntryIDが空で､かつ開始日が翌月である場合のみ新規登録をします｡
If checkFlg 1 And Cells(i, 9) = “” And Cells(i, 1) “” And Cells(i, 3).Value >= DateSerial(Year(Now), Month(Now) + 1, 0) And Cells(i, 3).Value = DateSerial(Year(Now), Month(Now) + 1, 0) And Cells(i, 3).Value <= DateSerial(Year(Now), Month(Now) + 2, 0) Then
■変更後
If Cells(i, 9) = “” And Cells(i, 3).Value >= DateSerial(Year(Now), Month(Now) + 1, 0) And Cells(i, 3).Value <= DateSerial(Year(Now), Month(Now) + 2, 0) Then
②変更の際の対象アイテム抽出期間
■変更前
intKikan = 1 '抽出期間を1か月にしています。
■変更後
intKikan = 6 '抽出期間を2か月以上にします。
③登録元データ
新規登録の際、I列のEntryIDは空、K列の終日の予定は「TRUE」になっているかご確認をお願い致します。
ご丁寧にありがとうございます。
メールなどでファイルをお送りすればよろしいでしょうか？
説明下手で申し訳ございません。
まずは、簡易的で結構ですので、以下の内容をコメントで送付いただければと存じます。
・登録しようとしているデータの詳細（登録できるデータとできないデータ2~3件）
→特に確認したい項目は開始日時、終了日時の日付の部分です。実際に使用した日付データを記載願いします。それ以外の項目はダミーデータで結構です。
・エラーの内容（表示されているエラーメッセージ、エラー発生箇所など）
→デバッグしてハイライトされているコードと、表示されているエラー番号をご教示ください。
横から失礼致します。
＞公開しているVBAの対象はPC版のOutlookとなり、
＞Web版は対象外となりますことご了承のほどお願いいたします。
私はアプリ版を持っておらず、実行するとブラウザ上でのカレンダーで登録が確認できます。
ブラウザでも登録される違いはなにかおわかりでしょうか？
「出席依頼を送信する方法！」について
「予定アイテム重複スキップ＆既存予定アイテム更新機能追加」に送信機能を付けたく、登録OR更新処理内に「.send」を入れましたが
新規登録後に再実行して全てのカラムの値が完全一致しているにも関わらず、スキップせず、更新処理が走ってしまいます。
なにか素人ゆえの見当違いがあるのかもしれませんが、こちらのコードで変更処理内に送信を入れるだけでは使えないのでしょうか？？
恐れ入りますが、ご教示いただけますと幸いです。
‘登録されている予定表の件名と開始日時及び終了日時が一致していなかった場合のみ更新
‘※更新の条件はご都合に応じて変更してください。この条件が無い場合はExcelの予定表すべて更新されますので、ご注意ください。
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
.send ←ここに追加
End With
End If
いつもご利用ありがとうございます。
Outlookアプリなしかつブラウザ版のみで稼働する件につきまして、
PCにExcelとOutlook Object Libraryがあるので最小限の実行環境がそろっているためと思われます。
この場合、当方に環境がなくサポートが難しいことご了承の程お願いいたします。
予定の送信を行えない件につきましては、Sendメソッドの前に
「.MeetingStatus = 1」※予定を “会議” に設定します。「olMeeting」でもOKです。
を追加するようお願いします。
予定を更新して再送信する方法については別の記事にまとめておりますので、よろしければこちらもご参照ください。
https://extan.jp/?p=3636#%E4%BC%9A%E8%AD%B0%E3%81%AE%E3%82%B9%E3%82%B1%E3%82%B8%E3%83%A5%E3%83%BC%E3%83%AB%E3%80%81%E5%86%85%E5%AE%B9%E3%82%92%E5%A4%89%E6%9B%B4%E3%81%97%E5%86%8D%E9%80%81%E4%BF%A1%E3%81%99%E3%82%8B
いつもお世話になっております。返信が遅くなり大変申し訳ございません。
下記内容で組んでおりますが、当月＋翌々月までの予定を登録するようにしたいのですが上手くいきません。
――――――――――――――――――――――――――――――――――――――――
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 = 1 ‘抽出期間を1か月にしています。
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) = “” And Cells(i, 1) “” And Cells(i, 3).Value >= DateSerial(Year(Now), Month(Now) + 1, 0) And Cells(i, 3).Value <= DateSerial(Year(Now), Month(Now) + 2, 0) 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
――――――――――――――――――――――――――――――――――――――――
以前ご教示いただいたものを入力かつ、私自身で調べたものを入れて工夫しているのですが上手くいかず・・・
・当月＋翌々月までの予定を登録を満たすのは下記であっているのでしょうか・・？
よろしくお願いいたします。
'EntryIDが空で､かつ開始日が翌月である場合のみ新規登録をします｡
If checkFlg 1 And Cells(i, 9) = “” And Cells(i, 1) “” And Cells(i, 3).Value >= DateSerial(Year(Now), Month(Now) + 1, 0) And Cells(i, 3).Value <= DateSerial(Year(Now), Month(Now) + 2, 0) Then
ご連絡ありがとうございます。
こちらでも検証いたしたく、以下をご教示いただけますでしょうか。
・登録しようとしているデータの詳細（登録できるデータとできないデータ2~3件）
・エラーの内容（表示されているエラーメッセージ、エラー発生箇所など）
よろしくお願いいたします。
タカヒロ様
有益な情報をありがとうございます！
一つ質問させてください。
私が使用しているものが、Web版のOutlookなのですが、今回の記事のVBAは使用できないでしょうか？
もし何か方法があればご教示いただけますと幸いです。
よろしくお願いいたします。
いつもご利用ありがとうございます。
ご質問のWeb版のOutlookの対応につきまして、
VBAはOfficeアプリが実行環境となりますため、
Officeアプリがない環境ですと対応は出来かねます。
対応といたしましては、Windows PCにデスクトップ版のOfficeアプリをインストールし、
Web版と同じアカウントで使用頂ければPCとWeb版で同期される形となり、VBAで操作は可能となります。
よろしくお願いいたします。
たびたび失礼いたします。
現在作成中の物は別シートで作成した予定表→outlookへ送り込むシートにまとめております。
現在、エラーが出ておりその原因として予測したのは
①予定がとびとびで途中で入力ができず登録できない？
→要件としては、1/1予定あり 1/2は未定のため空白 1/3予定あり・・・
といった具合の場合、1/1は登録できるものの、1/2でエラーが発生し、1/3以降登録できません。（現状：下記部分でデバッグ」と表示されます）
If checkFlg 1 Then
‘ExcelI列のEntryIDと登録されているEntryIDが一致していなかったら新規登録
With olItem
.Subject = Cells(i, 1)
.Location = Cells(i, 2)
.Start = Format(Cells(i, 3), “yyyy/mm/dd hh:mm:ss”)
空白の場合はスキップするなどの機能はあるのでしょうか…？
ご連絡ありがとうございます。
空白の場合はスキップさせる件ですが、
C列（左から3番目）の開始日時が空欄の場合を想定しますと、以下のようにすることで可能となっております。
■変更前
If checkFlg <> 1 Then
■変更後
If checkFlg <> 1 And Cells(i, 3) <> “” Then
※空白判定用の列は適宜変更頂ければと存じます。
ご返信ありがとうございます。
またご丁寧にご教示いただきありがとうございます。
早速やってみます。
こんにちは。
今回、参考にさせていただきExcel→outlookへの予定表入力を自動化させました。
①VBAを実行する際に、実行日を検知しその翌月の予定のみを反映させる
などといった便利なものはないでしょうか？
例）7月の予定が決まったがので6/25に7月の予定のみを実行しoutlookへ入力
※シート上には8月以降の予定もところどころ入力されている
②一つのシートに複数人の予定を入力し
それぞれの開始時間を設定しておりますが、「休み」を検知して時間入力せず終日の予定にするVBAなどはありますでしょうか？
説明不足かもしれませんがよろしくお願いいたします。
いつもご利用ありがとうございます。
①実行日を検知しその翌月の予定のみを反映させる方法につきまして、
「Outlookの予定表へ登録する_高速版」のコードの以下の部分を変更すれば対応可能となっております。
■変更前
‘EntryIDが空である場合のみ新規登録をすることにしました。
If checkFlg <> 1 And Cells(i, 9) = “” Then
■変更後
‘EntryIDが空で、かつ開始日が翌月である場合のみ新規登録をします。
If checkFlg <> 1 And Cells(i, 9) = “” And Cells(i, 3).Value >= DateSerial(Year(Now), Month(Now) + 1, 1) And Cells(i, 3).Value <= DateSerial(Year(Now), Month(Now) + 2, 0) Then DateSerial関数を使用して月末月初を取得する方法は以下の記事にまとめていますので、よろしければご参照ください。 https://extan.jp/?p=2421
②「休み」を検知して時間入力せず終日の予定にする方法につきまして、
AllDayEventプロパティをTrueにすることにより可能となります。
詳細はこちらの記事にまとめていますので、こちらもご参照頂ければと存じます。
https://extan.jp/?p=4375
やりかたとしては、Excel側に終日の予定の列を追加し、休みとした予定レコードの終日の予定セルへTRUEと入れます。
VBAを実行すると終日の予定のフラグをみてTrueであれば終日の予定として登録される形となります。
ご回答ありがとうございます！
やってみます！！
ブログの内容拝見させて頂き毎度大変勉強になっております。
ご質問ですが、Outlookの複数アカウントにExcelからスケジュール連携することはできないでしょうか？
例えば、Aさんがエクセルを操作して、Aさん、Bさん、Cさんに同じスケジュールを連携したいです。
いつもご利用ありがとうございます。
Outlookの複数アカウントにExcelからスケジュール連携する件につきまして、
Excel側の1つのスケジュールを複数人に登録ということであれば、
会議出席依頼という形で可能かと存じます。
詳細は以下の記事にまとめておりますのでご参考の程お願いいたします。
https://extan.jp/?p=3636
スケジュール変更＆変更通知の場合も記載がございます。
https://extan.jp/?p=3636#%E4%BC%9A%E8%AD%B0%E3%81%AE%E3%82%B9%E3%82%B1%E3%82%B8%E3%83%A5%E3%83%BC%E3%83%AB%E3%80%81%E5%86%85%E5%AE%B9%E3%82%92%E5%A4%89%E6%9B%B4%E3%81%97%E5%86%8D%E9%80%81%E4%BF%A1%E3%81%99%E3%82%8B
よろしくお願いいたします。
そうなのですね。ご回答ありがとうございます。
ブログの内容拝見させて頂き大変勉強になっております。
いつもありがとうございます。
本件はPCインストール版のOutlookに対しての処理であり、
Outlook on The Webには対応していないという認識でよいでしょうか。
いつもご利用ありがとうございます。
ご認識どおり、公開しているVBAの対象はPC版のOutlookとなり、
Web版は対象外となりますことご了承のほどお願いいたします。
説明不足で申し訳ありません。
複数人で共有しているエクセルファイル内の一部をコピペで張り付けたものを
outlookのスケジュールへ登録できるようにしようとしています。
下記マクロになりますが、3つの日付を登録できるようにはなりましたが、重複を回避することができない状態です。ご教授頂ければ幸いです。
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, 5) + “○○日”
.Location = Cells(i, 7)
.Start = Format(Cells(i, 11), “yyyy/mm/dd hh:mm:ss”)
End With
‘ここで保存
olItem.Save
Next
‘予定表一覧の件数分繰り返す。
For j = lnContactCount To Cells(1, 1).End(xlDown).Row
Set olItem = olApp.CreateItem(olAppointmentItem)
With olItem
.Subject = Cells(j, 5) + “△△日”
.Location = Cells(j, 7)
.Start = Format(Cells(j, 12), “yyyy/mm/dd hh:mm:ss”)
End With
‘ここで保存
olItem.Save
Next
‘予定表一覧の件数分繰り返す。
For k = lnContactCount To Cells(1, 1).End(xlDown).Row
Set olItem = olApp.CreateItem(olAppointmentItem)
With olItem
.Subject = Cells(k, 5) + “□□日”
.Location = Cells(k, 7)
.Start = Format(Cells(k, 13), “yyyy/mm/dd hh:mm:ss”)
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
ご連絡ありがとうございます。
重複とはマクロを2回以上繰り返し実行た場合に再び同じ内容で予定アイテムが登録されてしまう内容でよろしいでしょうか。
以下公開記事に重複をさせない方法を記載しておりますので、ご参考頂きたくお願いいたします。
https://extan.jp/?p=1693#%E3%80%90%E8%BF%BD%E5%8A%A0%E3%80%91%E4%BA%88%E5%AE%9A%E3%82%A2%E3%82%A4%E3%83%86%E3%83%A0%E9%87%8D%E8%A4%87%E3%82%B9%E3%82%AD%E3%83%83%E3%83%97%E7%89%88%E8%BF%BD%E5%8A%A0