OUTLOOKで他人のスケジュールが見にくいのでEXCELに出力するマクロ
いまいちOUTLOOKの予定表って見ずらくて他人の予定を把握しずらい。
もうちょっとシンプルなサイボ〇〇ライクな表示と印刷しやすい形にならないか？と思って、ちゃちゃっとＡＩ作成しました。ＡＩまじすごｗ
予定を入れる機能はありません。スケジュールを表示するだけです。
画面の見た目は、時間が青太文字のあと予定、土日祝日着色され、祝日表示されます。
人の作ったマクロファイルなんて怖くて開けないと思うのでオープンソースでｗ
使い方
EXCELで新規ファイル作成し、以下マクロを貼って実行すると、
【対象メアド】と【予定表】シートが作られるので、
【対象メアド】シートのＡ列にスケジュールを検索したいメアドを入れ
【予定表】シートの開始日、検索日数の黄色欄にそれぞれ入力して
更新ボタンを押すと、【予定表】シートにスケジュールを表示する
検索には時間がかかるので、パソコン放置する時にでも動かしておきましょう
もちろんファイル保存はマクロありで保存しないとだめですよ？
初めて実行する場合は、以下の【Microsoft Outlook●ObjectLibrary】を有効にしないと動きません
' =============================
' Outlook予定表 一括取得ツール
' =============================
Public Sub GetGroupSchedules_Final()
Dim olApp As Object, olNamespace As Object
Dim wsMain As Worksheet
Dim wsList As Worksheet
Dim isNewConfig As Boolean: isNewConfig = False
' --- 【追加】自動シート作成・チェック処理 ---
On Error Resume Next
Set wsList = ThisWorkbook.Worksheets("対象メアド")
Set wsMain = ThisWorkbook.Worksheets("予定表")
On Error GoTo 0
' 「対象メアド」シートがなければ作成
If wsList Is Nothing Then
Set wsList = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))
wsList.Name = "対象メアド"
wsList.Range("A1").Value = "アドレス"
wsList.Range("B1").Value = "名称用テキスト(任意)"
wsList.Columns("A:B").ColumnWidth = 25
isNewConfig = True
End If
' 「予定表」シート（メイン画面）がなければ作成
If wsMain Is Nothing Then
Set wsMain = ThisWorkbook.Worksheets.Add(After:=wsList)
wsMain.Name = "予定表"
isNewConfig = True
End If
' アクティブシートを「予定表」にする
wsMain.Select
' アドレスリストが空、または新規作成された直後の場合はメッセージを出して終了
If isNewConfig Or wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row < 2 Then
Beep
MsgBox "「対象メアド」シートのA列にメールアドレスを入力してください。" & vbLf & _
"入力後、もう一度マクロを実行するか「更新」ボタンを押してください。", vbInformation, "初期設定"
' ユーザーが入力しやすいように「対象メアド」シートを選択して終了
wsList.Select
' 初期状態でもボタンだけは「予定表」シートに配置しておく
Call SetupUpdateBtn(wsMain)
Exit Sub
End If
' --------------------------------------------
Beep
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
Set olNamespace = olApp.GetNamespace("MAPI")
On Error GoTo 0
If olApp Is Nothing Then MsgBox "Outlookを起動できませんでした。", vbCritical: Exit Sub
' --- 1. 期間とUIの設定 (1行目) ---
Dim startDate As Date: startDate = IIf(IsDate(wsMain.Range("B1").Value), wsMain.Range("B1").Value, Date)
Dim searchDays As Integer: searchDays = IIf(wsMain.Range("D1").Value > 0, wsMain.Range("D1").Value, 7)
Dim endDate As Date: endDate = startDate + searchDays - 1
wsMain.Range("B1").Value = startDate
wsMain.Range("D1").Value = searchDays
With wsMain
.Rows(1).RowHeight = 45
With .Range("A1:D1")
.Font.Name = "HG丸ｺﾞｼｯｸM-PRO": .Font.Size = 16: .VerticalAlignment = xlCenter
End With
.Range("B1").ShrinkToFit = True
.Range("A1").Value = "開始日：": .Range("C1").Value = "検索日数："
.Range("A1,C1").HorizontalAlignment = xlRight
.Range("D1").Interior.Color = vbYellow: .Range("D1").Font.Bold = True
.Rows("2:" & .Rows.Count).Clear
.Columns("A").ColumnWidth = 18: .Columns("C").ColumnWidth = 14
' ボタンの再作成
Call SetupUpdateBtn(wsMain)
End With
' --- 2. 日付ヘッダー作成 (2行目) ---
Application.ScreenUpdating = False
Dim col As Long, targetDate As Date, hName As String
wsMain.Cells(2, 1).Value = "氏名 / 日付"
wsMain.Rows(2).RowHeight = 39
For col = 0 To searchDays - 1
targetDate = startDate + col
hName = GetHolidayName(targetDate)
With wsMain.Cells(2, col + 2)
.Value = targetDate
.NumberFormatLocal = "m/d(aaa)"
If hName <> "" Then .Value = .Text & vbLf & hName
.Font.Name = "HG丸ｺﾞｼｯｸM-PRO": .Font.Size = 14: .Font.Bold = True
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = True
.ShrinkToFit = True
If hName <> "" Or Weekday(targetDate) = vbSunday Then
.Interior.Color = RGB(255, 230, 230): .Font.Color = vbRed
wsMain.Columns(col + 2).ColumnWidth = 18
ElseIf Weekday(targetDate) = vbSaturday Then
.Interior.Color = RGB(220, 230, 241): .Font.Color = vbBlue
wsMain.Columns(col + 2).ColumnWidth = 18
Else
.Interior.Color = RGB(250, 250, 250): .Font.Color = vbBlack
wsMain.Columns(col + 2).ColumnWidth = 22
End If
End With
Next
' --- 3. 予定取得処理 ---
Dim lastMailRow As Long: lastMailRow = wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row
Dim mailRow As Long, rowIdx As Long: rowIdx = 3
Dim mailAddr As String, recipient As Object, olFolder As Object
Dim colBValue As String, dispName As String
' 1行目の見出しスキップのため 2 からループ開始
For mailRow = 2 To lastMailRow
mailAddr = wsList.Cells(mailRow, "A").Value
colBValue = Trim(wsList.Cells(mailRow, "B").Value)
If mailAddr <> "" Then
Set recipient = olNamespace.CreateRecipient(mailAddr)
If recipient.Resolve Then
Set olFolder = Nothing
On Error Resume Next
Set olFolder = olNamespace.GetSharedDefaultFolder(recipient, 9)
On Error GoTo 0
dispName = recipient.Name
If colBValue <> "" Then
dispName = dispName & vbLf & colBValue
End If
If Not olFolder Is Nothing Then
wsMain.Cells(rowIdx, 1).Value = dispName
Call ProcessAppointments(olFolder, wsMain, rowIdx, startDate, endDate)
Else
wsMain.Cells(rowIdx, 1).Value = dispName & " (取得不可)"
wsMain.Cells(rowIdx, 1).Font.Color = RGB(150, 150, 150)
End If
End If
rowIdx = rowIdx + 1
End If
Next
' --- 4. 仕上げ ---
With wsMain.Range(wsMain.Cells(2, 1), wsMain.Cells(rowIdx - 1, searchDays + 1))
.Borders.LineStyle = 1: .VerticalAlignment = xlTop: .WrapText = True
End With
If rowIdx > 3 Then wsMain.Rows("3:" & rowIdx - 1).AutoFit
Application.ScreenUpdating = True
Beep
MsgBox "更新しました。"
End Sub
' --- 予定取得サブ ---
Private Sub ProcessAppointments(folder As Object, ws As Worksheet, rowIdx As Long, sDate As Date, eDate As Date)
Dim filter As String: filter = "[End] >= '" & Format(sDate, "yyyy/mm/dd 00:00") & "' AND [Start] <= '" & Format(eDate, "yyyy/mm/dd 23:59") & "'"
Dim items As Object: Set items = folder.items
items.IncludeRecurrences = True: items.Sort "[Start]"
Dim restrictedItems As Object: Set restrictedItems = items.Restrict(filter)
Dim appt As Object, checkDate As Date, targetCol As Long, timeStr As String
For Each appt In restrictedItems
For checkDate = Int(appt.Start) To Int(appt.End)
If checkDate = Int(appt.End) And Format(appt.End, "HH:mm") = "00:00" Then Exit For
If checkDate >= sDate And checkDate <= eDate Then
targetCol = (checkDate - sDate) + 2
If appt.AllDayEvent Then
timeStr = "【終日】"
Else
timeStr = Format(appt.Start, "HH:mm") & "-" & Format(appt.End, "HH:mm")
End If
With ws.Cells(rowIdx, targetCol)
.Value = .Value & IIf(.Value <> "", vbLf, "") & timeStr & " " & appt.Subject
End With
End If
If checkDate > eDate Then Exit For
Next
Next
' --- 装飾処理 ---
Dim c As Long, i As Long, pos As Long, lines Variant, decoLen As Integer
For c = 2 To (eDate - sDate) + 2
If ws.Cells(rowIdx, c).Value <> "" Then
lines = Split(ws.Cells(rowIdx, c).Value, vbLf): pos = 1
For i = 0 To UBound(lines)
decoLen = IIf(lines(i) Like "##:##-##:##*", 11, IIf(lines(i) Like "【終日】*", 4, 0))
If decoLen > 0 Then
With ws.Cells(rowIdx, c).Characters(pos, decoLen).Font
.Color = vbBlue: .Bold = True
End With
End If
pos = pos + Len(lines(i)) + 1
Next
End If
Next
End Sub
' --- 複数年対応・祝日自動判定ロジック ---
Private Function GetHolidayName(targetDate As Date) As String
Dim y As Integer, m As Integer, d As Integer, w As Integer
Dim hName As String
y = Year(targetDate)
m = Month(targetDate)
d = Day(targetDate)
w = Weekday(targetDate)
hName = ""
Select Case m
Case 1
If d = 1 Then hName = "元日"
If d = GetNthWeekday(y, 1, 2, 2) Then hName = "成人の日"
Case 2
If d = 11 Then hName = "建国記念の日"
If d = 23 Then hName = "天皇誕生日"
Case 3
If d = GetVernalEquinox(y) Then hName = "春分の日"
Case 4
If d = 29 Then hName = "昭和の日"
Case 5
If d = 3 Then hName = "憲法記念日"
If d = 4 Then hName = "みどりの日"
If d = 5 Then hName = "こどもの日"
Case 7
If d = GetNthWeekday(y, 7, 2, 3) Then hName = "海の日"
Case 8
If d = 11 Then hName = "山の日"
Case 9
Dim keiro As Integer, syunbun As Integer
keiro = GetNthWeekday(y, 9, 2, 3)
syunbun = GetAutumnalEquinox(y)
If d = keiro Then
hName = "敬老の日"
ElseIf d = syunbun Then
hName = "秋分の日"
ElseIf d = keiro + 1 And d = syunbun - 1 Then
hName = "国民の休日"
End If
Case 10
If d = GetNthWeekday(y, 10, 2, 2) Then hName = "スポーツの日"
Case 11
If d = 3 Then hName = "文化の日"
If d = 23 Then hName = "勤労感謝の日"
End Select
If hName <> "" Then
GetHolidayName = hName
Exit Function
End If
' --- 振替休日の判定 ---
If w = 2 Then
If GetHolidayName(targetDate - 1) <> "" And GetHolidayName(targetDate - 1) <> "振替休日" Then
GetHolidayName = "振替休日"
Exit Function
End If
ElseIf m = 5 And d = 6 And (w = 3 Or w = 4) Then
If Weekday(DateSerial(y, 5, 3)) = 1 Or Weekday(DateSerial(y, 5, 4)) = 1 Or Weekday(DateSerial(y, 5, 5)) = 1 Then
GetHolidayName = "振替休日"
Exit Function
End If
End If
GetHolidayName = ""
End Function
Private Function GetNthWeekday(y As Integer, m As Integer, targetW As Integer, n As Integer) As Integer
Dim firstDay As Date, firstW As Integer, dayOffset As Integer
firstDay = DateSerial(y, m, 1)
firstW = Weekday(firstDay)
dayOffset = targetW - firstW
If dayOffset < 0 Then dayOffset = dayOffset + 7
GetNthWeekday = 1 + dayOffset + (n - 1) * 7
End Function
Private Function GetVernalEquinox(y As Integer) As Integer
Select Case y Mod 4
Case 0, 1, 2: GetVernalEquinox = Int(20.8431 + 0.242194 * (y - 1980) - Int((y - 1980) / 4))
Case 3: GetVernalEquinox = Int(21.2421 + 0.242194 * (y - 1980) - Int((y - 1980) / 4))
End Select
End Function
Private Function GetAutumnalEquinox(y As Integer) As Integer
Select Case y Mod 4
Case 0, 1, 2: GetAutumnalEquinox = Int(23.2488 + 0.242194 * (y - 1980) - Int((y - 1980) / 4))
Case 3: GetAutumnalEquinox = Int(24.2488 + 0.242194 * (y - 1980) - Int((y - 1980) / 4))
End Select
End Function
' --- ボタン作成サブ ---
Private Sub SetupUpdateBtn(ws As Worksheet)
Dim btn As Object
For Each btn In ws.Shapes
If btn.Name = "Btn_UpdateSchedules" Then btn.Delete
Next btn
Set btn = ws.Shapes.AddShape(5, ws.Range("E1").Left + 5, 5, 120, 35)
With btn
.Name = "Btn_UpdateSchedules"
.OnAction = "'" & ThisWorkbook.Name & "'!GetGroupSchedules_Final"
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.Solid
.Line.ForeColor.RGB = vbBlack
.Line.Weight = 2.25
With .TextFrame
.Characters.Text = "更 新"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Characters.Font
.Name = "HG丸ｺﾞｼｯｸM-PRO"
.Size = 24
.Bold = True
.Color = vbRed
End With
End With
End With
End Sub