①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 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 = 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)
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) = "" 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)
'終日の予定であるか指定します。
.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
利用させていただいております。ありがとうございます。 現在以下のようなコードで利用させていただいており、 更新の際に終日予定が重複した場合は飛ばす機能は正常に作動し、終日予定が異なる日は追加で予定が埋められるという形になっております。 そこに終日の予定が異なる際は前の予定を削除して、追加で予定を埋めるような機能を入れたいのですが、削除のコードをどのように利用すればよいでしょうか。 ご教授いただけると幸いです。
——————————————————————————————
Sub Outlookの予定表へ登録する()
Dim ans As String
ans = InputBox(“あなたの番号は？”)
‘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
‘Excelのブックとワークシートのオブジェクトを設定します。
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets(1) ‘ワークシート2を参照
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 = 4
mn = ans + 10
x = Range(“D8”).End(xlToRight).Column
Dim rc As Integer
rc = MsgBox(“予定表を更新します。あなたは本当に【” & Cells(mn, 3) & “】さんですか？”, vbYesNo + vbQuestion, “確認”)
If rc = vbYes Then
‘予定表一覧の件数分繰り返す。
For i = lnContactCount To x
Set olItem = olApp.CreateItem(olAppointmentItem)
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
‘キャンセル処理追加
’件名に削除の文字列があるかチェックします。
If InStr(Cells(i, 1), “削除”) Then
With olItemBefor
.MeetingStatus = 5 ‘予定を “キャンセル” に設定します。 ※「olMeetingCanceled」でもOK
.Delete ‘会議アイテムを削除します。
Cells(i, 9) = “” ‘Excelに書き込まれたEntryIDを削除します。
End With
Else
’削除の文字列がない場合は通常の変更処理をおこないます。
With olItemBefor
＜これまでの変更処理＞
End With
End If
【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へ終日の予定を登録する方法！複数日指定も！
ご回答いただきありがとうございました。
無事、解決できました。
もう一点質問させてください。
こちら会議出席者を指定して、終日の予定を入れる事は可能でしょうか？
必須出席者の欄に、必須出席者のアドレスを入力しマクロを実行しても自分のOutlookにしか予定が入らず。
もし必須出席者を入れて、終日の予定を登録する方法がありましたらご教示ください。
解決されたようでよかったです。
追加の会議出席者に対して予定を入れる方法につきましては、
以下の記事をご参考願います。
https://extan.jp/?p=3636
具体的にはsaveメソッドで自分のみ保存している処理のところを
sendメソッドに変更し、会議出席者へ送信するようにしていただければと存じます。
いつも活用させていただいております。ありがとうございます。
こちらのコードを新しいファイルに入れ直したところ、
「オーバーフローしました」のエラー表示で実行できなくなってきてまいました。
デバックで黄色になる箇所は下記です。
‘予定表一覧の件数分繰り返す。
For i = lnContactCount To Cells(1, 1).End(xlDown).Row ←ここ
Set olItem = olApp.CreateItem(olAppointmentItem)
どうにも修正できず、コメントさせていただきました。
恐れ入りますが解決策を教えてください。よろしくお願いします。
いつもご利用ありがとうございます。
「オーバーフローしました」のエラーにつきまして、おそらく最終行数がキャパを超える数値になっている可能性がありますので、
「Cells(1, 1).End(xlDown).Row」の数値が何件になっているかデバッグしてご確認いただけますでしょうか。
この処理は数式やスペース記号がはいっていると見た目は空欄でも最終行と判定されますのでご注意願います。
次に、登録件数を10件以下に絞ってうまくいくかご確認いただけますでしょうか。
特定のアイテムでエラーとなる場合はそのアイテムを一旦削除し再実行してみてください。
よろしくお願いいたします。
早速のお返事ありがとうございます。
今回の場合ですと、イベントがかぶっていない時、つまりcheckflg=0の予定の際に前の既存の予定を消したいのですが、具体的にどこにコードを打てばよいでしょうか？
無知で申し訳ございませんが、ご教授いただけると幸いです。
コードについてはFor Each文内に以下を設置する形になるかと存じます。
ただし、checkflg=0の場合の条件にしますと、頂いたコードでは初期値が0であるため、
checkflg=1以外の予定が削除される形となりますので、ご注意ください。
If ＜既存予定アイテムを削除する条件＞ Then
olItemBefor.Delete
End If
「イベントがかぶっていない時」の条件について、具体的に何と何が異なった場合なのかを定義いただき、条件式を定めた上、
本番実装前に十分にテストを行うことを推奨いたします。
利用させていただいております。ありがとうございます。 現在以下のようなコードで利用させていただいており、 更新の際に終日予定が重複した場合は飛ばす機能は正常に作動し、終日予定が異なる日は追加で予定が埋められるという形になっております。 そこに終日の予定が異なる際は前の予定を削除して、追加で予定を埋めるような機能を入れたいのですが、削除のコードをどのように利用すればよいでしょうか。 ご教授いただけると幸いです。
——————————————————————————————
Sub Outlookの予定表へ登録する()
Dim ans As String
ans = InputBox(“あなたの番号は？”)
‘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) ‘ワークシート2を参照
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 = 4
mn = ans + 10
x = Range(“D8”).End(xlToRight).Column
Dim rc As Integer
rc = MsgBox(“予定表を更新します。あなたは本当に【” & Cells(mn, 3) & “】さんですか？”, vbYesNo + vbQuestion, “確認”)
If rc = vbYes Then
‘予定表一覧の件数分繰り返す。
For i = lnContactCount To x
Set olItem = olApp.CreateItem(olAppointmentItem)
With olItem
.Subject = Cells(mn, i)
.Start = Format(Cells(51, i), “yyyy/mm/dd”)
.End = Format(Cells(51, i + 1), “yyyy/mm/dd”)
.AllDayEvent = Cells(1, 1)
.Categories = “Orange category”
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
いつもご利用ありがとうございます。
既存の終日の予定を削除するコードにつきましては、頂いたコードの中の
For Each文内にある既存の予定アイテムのolItemBeforに削除のDeleteメソッドを加えることにより対応可能です。
以下のように条件指定の上設定いただければと存じます。
If ＜既存予定アイテムを削除する条件＞ Then
olItemBefor.Delete
End If
利用させていただいております。ありがとうございます。
現在以下のようなコードで利用させていただいており、
更新の際に終日予定が重複した場合は飛ばす機能は正常に作動し、終日予定が異なる日は追加で予定が埋められるという形になっております。
そこに終日の予定が異なる際は前の予定を削除して、追加で予定を埋めるような機能を入れたいのですが、削除のコードをどのように利用すればよいでしょうか。
ご教授いただけると幸いです。
早々にご返信いただき本当にありがとうございました。
無事解決しました！
1回では削除されずに2回実行で削除が完了するのが謎のままなんですが、許容範囲としてこのまま使わせていただきます。
先日お教えいただいたスケジュールの登録、変更については問題なく使えております。ありがとうございました。
今回はスケジュールの削除についてお教えください。
登録した終日のスケジュールがキャンセルとなった場合、もともとのスケジュールの件名内に”削除”と入っているスケジュールを削除したいのですが、可能でしょうか？
ご連絡ありがとうございます。
キャンセル処理の件ですが、以下のように追加すれば対応可能となっております。
‘キャンセル処理追加
’件名に削除の文字列があるかチェックします。
If InStr(Cells(i, 1), “削除”) Then
With olItemBefor
.MeetingStatus = 5 ‘予定を “キャンセル” に設定します。 ※「olMeetingCanceled」でもOK
.Delete ‘会議アイテムを削除します。
Cells(i, 9) = “” ‘Excelに書き込まれたEntryIDを削除します。
End With
Else
’削除の文字列がない場合は通常の変更処理をおこないます。
With olItemBefor
＜これまでの変更処理＞
End With
End If
別記事となりますが会議のキャンセルをする方法についてまとめていますので、
よろしければこちらもご参考ください。
https://extan.jp/?p=3636#%EF%BC%9C%E8%BF%BD%E5%8A%A0%EF%BC%9EExcel%E3%81%8B%E3%82%89%E7%99%BB%E9%8C%B2%E6%B8%88%E3%81%BF%E4%BC%9A%E8%AD%B0%E3%81%AE%E3%82%AD%E3%83%A3%E3%83%B3%E3%82%BB%E3%83%AB%E9%80%9A%E7%9F%A5%E3%82%92%E3%81%99%E3%82%8B
ご返信ありがとうございました。
解決しました！
Ａ列には他の複数のスケジュール表から参照するために、反映すべきスケジュールがない場合は空欄、とう数式を入れておりました。
こちらを削除しましたらエラーは出なくなりましたのでこれが原因かと思います。
今後はこのスケジュール欄を別セルに値貼付けするマクロを追加し、その後にこちらのマクロを動かせるよう組んでみます。
大変お手数をおかけしました。
今後ともよろしくお願いいたします
できたようでよかったです。
数式の結果が空欄でも最終行判定では値があるものとして判断されることが要因ですね。
値貼り付けで数式を含まない形で処理いただければ問題なく動くかと存じます。
よろしくお願いいたします。
五月雨式に申し訳ございません。
ご教示いただいた内容で確認いたしました。
結果からお伝えすると①と②はエラーが出ました。
※エラーは出ていますが、Outlookに新規登録や変更登録はできています。
※エラーの出る場所は同じ箇所です。
—————-
‘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”) ←この行です
—————-
以下、確認内容です。
①1シート目以外のシートに値を設定していないか
サンプルにあるように1シート目のセルを参照しております。エラーが出たのでシート名を指定して再度実行しましたがやはりエラーが出てしまいました。
②セルのプロパティを指定して値を渡す
Value/Textプロパティを指定しましたが、やはりエラーが出ました。
（マクロ中の3か所にそれぞれを入れました）
③値をべた書きで渡す
エラーは出ませんでしたが、複数登録したいのとvba（というかエクセル）に慣れていない方たちに配布するべく作成したいので、べた書きでは対応できない状況です。
ご連絡ありがとうございます。
予定の新規登録、変更は可能で③のべた書きは問題なし、①②はＮＧとなると、コードではなくデータに問題がある可能性があります。
そこでお手数ですがA列に値（半角スペースや改行なども含む）があって、C列以降空となっている行はないかご確認いただけますでしょうか。
コードではA列の最終行を判定し、最終行から先頭行まで処理を繰り返す仕様となっていますが、
A列だけに値がある場合でも処理対象としてカウントされてしまい、C列以降の値はないためエラーとなります。
もし該当する行レコードがあれば削除した上再度実行頂きたくお願いいたします。
お世話になります。
昨夜型が一致しないとコメントした件で補足がありました。
エラーは出ていますが、Outlookに新規登録や変更登録はできています。
エラーの出る場所は同じ下記の部分です。
—————-
‘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”) ←この行です
—————-
シリアル値であることも確認しています。
どうぞよろしくお願いいたします。
お世話になります。
終日予定をExcelからOutlookに行いたく、こちらのページを参照させていただいております。
以前のコメントにもありますが、
エラー13：型が一致しません
と出てしまい、ご返信されているのを参考に確認を重ねておりますが一向に解決できずにおります。
エラーの出る箇所は
.Start = Format(Cells(i, 3), “yyyy/mm/dd hh:mm:ss”)
です。
Office365のExcelとOutlookを使用しています。
開始には別シートからVLOOKで参照し、終了は開始＋1としています。元の値は日付です。（参照が原因かと思い直接入力しましたがダメでした）
いずれも ”yyyy/mm/dd hh:mm:ss” に表示設定できています。
考えられる原因と対処方がありましたらご教示いただきたく、よろしくお願いいたします。
いつもご利用ありがとうございます。
エラー13となってしまう原因ですが、Startプロパティの指定型にあっていない為となります。
ただ、色々試されたかと存じますので、入力値は日付型である前提とし、以下をご確認頂きたくお願いいたします。
①1シート目以外のシートに値を設定していないか
本コードは1シート目のセルを参照しており、表が1シート目に位置しているか確認をお願いします。
②セルのプロパティを指定して値を渡す
Value/Textプロパティを指定して確認をお願いします。
.Start = Format(Cells(i, 3).Value, “yyyy/mm/dd hh:mm:ss”)
.End = Format(Cells(i, 4).Value, “yyyy/mm/dd hh:mm:ss”)
もしくは
.Start = Format(Cells(i, 3).Text, “yyyy/mm/dd hh:mm:ss”)
.End = Format(Cells(i, 4).Text, “yyyy/mm/dd hh:mm:ss”)
③値をべた書きで渡す
以下のように値を直接入力し確認をお願いします。
.Start = Format(“2022/06/06 00:00:00”, “yyyy/mm/dd hh:mm:ss”)
.End = Format(“2022/06/07 00:00:00”, “yyyy/mm/dd hh:mm:ss”)
よろしくお願いいたします。
お世話になっております。VBA初心者です。終日予定をExcelからOutlookに行いたく、こちらのページを参照させていただいたのですが、
エラー13：方が一致しません
と出てしまい、困っております。以下の部分が原因のようですがどのように対処すればよろしいでしょうか。
“yyyy/mm/dd hh:mm:ss”
ご指南いただけますと大変ありがたく思います。
いつもご利用ありがとうございます。
型が一致しないエラーとなる件ですが、
入力した値が日時のシリアル値に変換できないことが原因と思われます。
サンプル通りですと、C列、D列に日時を入れているかと存じますが、全角英数字などで入れていないか
ご確認頂けますでしょうか。
また、11/11の場合はC列「2021/11/11 0:00:00」、D列「2021/11/12 0:00:00」となりますので、
こちらも試していただければと存じます。
分類の色を選択したいのですが、追加でご教示頂けますでしょうか。
いつもご利用ありがとうございます。
分類の色を追加する件ですが、
Categoriesプロパティへ分類名を指定することで設定が可能です。
例えばデフォルトの”オレンジの分類”のオレンジ色を指定する場合は、
.Categories = “オレンジの分類”
とし、.Saveメソッドの上あたりに入れて
実行してみてください。
ありがとうございます。
参考にさせていただきました。
エクセル上に”予約者”の列を追加しているので
必須出席者(RequiredAttendees)と任意出席者(OptionalAttendees)を登録するセルの指定数字がずれているかと。
ご指摘ありがとうございます。
確かに必須出席者と任意出席者のセルとVBAの指定セルがずれておりましたので、
公開コードを修正させて頂きました。
すみません。この記事と関係ない内容の質問をします。
VBAでリダイレクト処理をしたいのですがご教授願えますか？
仕分けルールで転送設定をすると、送ってきた人のアドレスが転送先に表示されてしまうので、そこを自分に変えるだけのスクリプトで構いません。
環境は Win10 / Outlook2016 です。Exchange Server は使わず、スクリプト処理のみの方法を模索しています。
大変恐れ入りますが、よろしくお願い致します。
いつもご利用ありがとうございます。
仕分けルール+スクリプト（差出人を元の差出人ではなく転送者に変更）実行の組み合わせでリダイレクトを実現したいということでよろしいでしょうか。
仕分けルールからスクリプトを実行するメニューはOutlook2010以降、セキュリティ対策の観点で非表示となっていますので、まずはスクリプト実行メニューを表示させるレジストリ設定の必要があります。
キー : HKEY_CURRENT_USER\Software\Microsoft\Office\xx.0\Outlook\Security
名前: EnableUnsafeClientMailRules
種類: REG_DWORD
値: 1 (有効)
※レジストリ キーのパス中にある xx の選択
Outlook 2016 の場合 : 16
【ご参考】
https://qiita.com/Q11Q/items/a83b2d1434e93289058f
すでに対応されているようでしたらご放念ください。
次に転送メールの差出人をご自身に変更する処理は、Forwardメソッドを利用します。
通常リダイレクト処理は元メールをコピーして送信しますが、その場合、差出人は元の差出人に固定されます。（VBA上でSenderEmailAddressプロパティに格納されていますが、読み取り専用となり、変更はできません。）
そこで元メールをForwardメソッドで転送メールとして処理します。
転送メールですので、差出人は転送した人のアドレスに置き換わる、つまりご自身のアドレスになるというわけです。
VBAは以下となります。
Sub 対象メールをコピーして送信する_カスタムルール(Item As Outlook.MailItem)
Dim objFwItem As Outlook.MailItem
‘ルールの条件に該当したメールアイテムを転送としてセットします。
Set objFwItem = Item.Forward
‘転送先を指定します。
‘転送先アドレスを指定してください。
objFwItem.To = “***@****.***”
‘件名を指定します。
objFwItem.Subject = Item.Subject & “＜メール転送のテストです＞”
‘メール本文を指定します。
objFwItem.Body = “↓↓↓以下転送元の内容となります。↓↓↓” & vbCrLf _
& Item.Body
‘送信します。
objFwItem.Recipients.ResolveAll
objFwItem.Send
End Sub
ルールの条件にスクリプトで実行を選択し、上記VBAを指定してください。
こちらの環境（Win10 / Outlook2016）で実行まで確認できました。
ご不明な点等ありましたらご連絡ください。