[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数のOutlook予定表データから共通の空き時間を抽出』（でーえっくす）
いつも勉強させていただいております。
複数のOutlook予定表データから共通の空き時間を抽出するアイディアなどなにかあるでしょうか？
10人～15人程度の1ヶ月間のOutlook予定を確認し、全員共通の空き時間に会議を入れる業務をしております。
かなり時間がかかる業務なので、データで抽出できないかと考えており、
Outlookから1ヶ月間の人数分の予定データをDLする所まではVBAで何とか自動化できそうです。
（ネットのコピペですが....）
Outlook予定データをDLできたは良いものの、内容が以下のようになっており、共通の空き時間をどうやって探してくるかのアイディアが思いつきません。
氏名 予定名 予定日 開始時刻 終了時刻
○○〇 ○○会議 2021/7/7 11:00:00 12:00:00
・ ・ ・ ・ ・
・ ・ ・ ・ ・
△△△ △△会議 2021/7/7 13:00:00 15:00:00
・ ・ ・ ・ ・
・ ・ ・ ・ ・
上記データの見えている部分だけで考えますと、7/7の空き時間は 11:00～12:00 / 13:00～15:00 以外 という事になります。
皆さまの知恵をお借りできればと思いますので、宜しくお願い致します。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
ちょっと情報が不足気味です。
各自の予定は、時間単位なのかどうか（分単位もあるのか）
空き時間も時間単位なのか、分単位で考えるのか。(1分空いていても意味ないが・・） 何時から何時までが空き時間判定の範囲なのか。(早朝、真夜中まであり？） 土日祝も空き判定の考慮対象日なのか。
Outlookのデータは目的月の分だけが抽出されているのか。(余計な月も混在？）
１人でも埋まっていたら、純然たる空きではないが、場合によっては １人くらい都合が悪くても(または特定の人だけ都合がつかないだけなら）、 空き判定にするなんてこともあるのかどうか？
（半平太） 2021/07/07(水) 16:27
ご返答ありがとうございます。
また情報が不足しており申し訳ございません。
１．各自の予定は、時間単位なのかどうか（分単位もあるのか）
Outlook予定上では分単位でも登録可能なので、分単位での予定もあります...
２． 空き時間も時間単位なのか、分単位で考えるのか。(1分空いていても意味ないが・・）
15分もしくは30分単位などで抽出できたら良いなと思っております。
ただ、実現が難しければ、1時間単位での検索/抽出でも十分業務負担軽減になります！
３．何時から何時までが空き時間判定の範囲なのか。(早朝、真夜中まであり？）
9:00～18:00で考えております
４．土日祝も空き判定の考慮対象日なのか。
土日祝は対象外として抽出したいです。
５．Outlookのデータは目的月の分だけが抽出されているのか。(余計な月も混在？）
Outlookのデータは一ヶ月間で取り出しております。
６．１人でも埋まっていたら、純然たる空きではないが、場合によっては１人くらい都合が悪くても
(または特定の人だけ都合がつかないだけなら）、空き判定にするなんてこともあるのかどうか？
理想は、1人が都合が悪い場合/2人が都合が悪い場合と選択できたら良いと思いますが、
難しいと思うので、全員空いてないとダメという形でも大変助かります。
宜しくお願い致します。
（でーえっくす） 2021/07/08(木) 11:12
デスクトップ版のOutlookを使用しているのならば 自分のアプリに共有の予定表などで他の方のスケジュールが見れるように設定しておき 必要な方の名前の前のチェックをチェックしておきグループスケジュールにすれば 共通の空き時間を見ることが出来ると思うのですが違うのかな
空き時間の表示では表示しないのかな？すべての詳細を表示なら見えますが
OutlookのWeb版だと色でしか他の方の予定はわかりませんがそれでも空いているところは わかるような気がしますがどうでしょうか （なるへそ） 2021/07/08(木) 15:45
１．シート「BackOffice」を挿入して、A2セル以下に祝日一覧を入力してください。 その一覧範囲に「祝日」と名前定義してください。 なお、このシートは、他の目的にも使用します。
２．更にもう一枚挿入して、シート名を「空き状況」シートとしてください。 このシートには以下の条件付き書式を設定してください。
条件式→ =AND($B4<>"",BackOffice!C4<=$F$2,C$3<>"") 適用範囲→ =$C$4:$Y$43 書式は黄色(色はそちらのお好みで）
３．．アウトルックから作成したシートは「個人予定表」と言うシート名にしてください。 ※逆に、プログラムの方を、そちらの実際のシート名に変更してもいいです。 レイアウトは下図の通りとします。
<個人予定表 シート レイアウト> 行 ___A___ ____B____ ____C____ ____D____ ____E____ 1 氏名 予定名 予定日 開始時刻 終了時刻 2 ○○○ ○○会議 2021/7/1 8:15 12:00 3 △△△ △△会議 2021/7/6 13:00 15:00 4 ○○○ △△会議 2021/7/6 12:00 13:00
４．空き状況シートは白紙の状態で結構です。 その場合、「時間の間隔」は、1:00となります。 それ以外の間隔を指定したいときはE2セルに手入力してください。(例→ 0:20 ） 時間の間隔は、1:00、0:30、0:20、0:15の4種のみとします。(それ以外は指定しないでください） ※時間間隔を変更したときは、マクロを再実行してください。
５．下記マクロは、空き状況シートの「シートモジュール」に貼り付けてください。 (重要：標準モジュールにではない）
６．アウトルックからのデータが整ったら、空き状況シートの「ShowVacancy」を実行する。 すると、空き枠のセルが黄色く着色されます。
７．0人以下じゃなくてもいい場合は、F2セルにその人数を入れてください。 条件付き書式で自動的に色が変わります。(マクロの再実行は必要ないです）
’貼り付けるマクロ(BackOfficeのシートモジュールへ）
Sub ShowVacancy()
Const adjustSecond As Double = 0.00001
Dim WsSche As Worksheet
Dim WsBkOffice As Worksheet
Dim thisFirst As Double
Dim nextFirst As Double
Dim startPos, endPos As Long
Dim maxRangeAddress As String
Dim CheckAry() As Double
Dim numFilled()
Dim WKdays
Dim WKzone As Long
Dim Col As Long
Dim d, t, m, i
Dim cel As Range
Dim App As Application
Set App = Application
Set WsSche = Worksheets("個人予定表")
Set WsBkOffice = Worksheets("BackOffice")
'空き状況シートを整形
thisFirst = WsSche.Evaluate("個人予定表!C2-DAY(個人予定表!C2)+1")
nextFirst = DateAdd("m", 1, thisFirst)
Application.ScreenUpdating = False
With Me
If .Range("E2") = "" Then
.Range("E2") = ["1:00"*1]
End If
.Range("B1:F1") = [{"月初","開始時刻","終了時刻","時間間隔","人以下"}]
.Range("B2") = thisFirst '月初を表示
.Range("C2:D2") = Array(TimeValue("8:00"), TimeValue("18:00")) '開始・終了時刻を表示
.Range("C3").Resize(, 23).ClearContents
WKdays = .[NETWORKDAYS(B2,EOMONTH(B2,0),祝日)]
.Range("C3").Resize(, WKdays) = .[INDEX(WORKDAY(B2-1,COLUMN(A1:BE1),祝日),0)]
WKzone = .[ROUND((D2-C2)/E2,0)] + 1
maxRangeAddress = Range("C4").Resize(44, 23).Address
.Range(maxRangeAddress).ClearContents
WsBkOffice.Range(maxRangeAddress).ClearContents
.Range("B4").Resize(44).ClearContents
With .Range("B4").Resize(WKzone)
.FormulaLocal = "=TEXT(C$2+(ROW()-4)*E$2,""[h]:mm"")*1"
.Value = .Value
End With
End With
ReDim numFilled(1 To WKzone, 1 To WKdays)
For Col = 3 To WKdays + 2
ReDim CheckAry(0 To WKzone) ' 先頭の0はエラー防止の為
With Me
For i = 1 To WKzone
CheckAry(i) = .Cells(3, Col) + .Range("B3").Offset(i)
Next i
End With
For Each cel In WsSche.Range("C2", WsSche.Cells(Rows.Count, "C").End(xlUp))
startPos = Application.Match(CDbl(cel + cel.Offset(, 1)), CheckAry)
endPos = Application.Match(CDbl(cel + cel.Offset(, 2) - adjustSecond), CheckAry)
For t = startPos To endPos
If startPos > 1 And endPos > 1 Then
numFilled(t - 1, Col - 2) = numFilled(t - 1, Col - 2) + 1
End If
Next t
Next cel
numFilled(WKzone, Col - 2) = 100 '18時ゾーンはダミー(100)を強制入力
Next Col
With WsBkOffice '結果をバックオフィスに打ち出し
.Range(maxRangeAddress).ClearContents
.Range("C4").Resize(WKzone, WKdays) = numFilled
End With
Application.ScreenUpdating = True
End Sub
（半平太） 2021/07/08(木) 23:33
おはようございます。 面白そうなので思い付きでちょっと書いてみました。
仕掛けは、各日付単位で 15分間隔の配列を作っておいて、、予定に含まれる場合は、、消していきます。 で、最終的に残ったところが共通の「空き時間」ということになる？と思います。 ただ、2021/7/7の11:00:00の様に一行しか残っていないデータは実際には使えません。(そこは、目で判断してください。。。おおぉぉいいい！m(__)m)
こんな↓データがあったとして
|[A] |[B] |[C] |[D] |[E]
[1] |氏名 |予定名 |予定日 |開始時刻|終了時刻
[2] |○○〇|○○会議|2021/7/7 |11:00:00|12:00:00
[3] |△△△|△△会議|2021/7/7 |13:00:00|15:00:00
[4] |○○〇|○○会議|2021/7/8 |13:00:00|16:00:00
[5] |△△△|△△会議|2021/7/7 |14:00:00|15:00:00
[6] |○○〇|○○会議|2021/7/7 |8:15:00 |11:00:00
[7] |△△△|△△会議|2021/7/7 |12:45:00|15:00:00
[8] |○○〇|○○会議|2021/7/8 |11:00:00|14:00:00
[9] |○○〇|○○会議|2021/7/10|8:15:00 |11:00:00
[10]|△△△|△△会議|2021/7/11|12:45:00|15:00:00
[11]|○○〇|○○会議|2021/7/12|11:00:00|14:00:00
[12]|○○〇|○○会議|2021/7/8 |9:00:00 |9:30:00
[13]|○○〇|○○会議|2021/7/10|10:00:00|11:00:00
[14]|△△△|△△会議|2021/7/11|11:00:00|12:00:00
[15]|○○〇|○○会議|2021/7/12|13:00:00|15:00:00
結果は、こう↓なります。表示されているところが空いている時間帯になります。。。 ここから活用していただけますと幸甚ですけど、、参考にならなかったら、、ゴミ箱にポイ(^^)/~~~しといてください。。 では、、では、、、
|[A] |[B] |[C] |[D] |[E]
[1] |2021/7/7|2021/7/8|2021/7/10|2021/7/11|2021/7/12
[2] |8:00:00 |8:00:00 |8:00:00 |8:00:00 |8:00:00
[3] |8:15:00 |8:15:00 |8:15:00 |8:15:00 |8:15:00
[4] | |8:30:00 | |8:30:00 |8:30:00
[5] | |8:45:00 | |8:45:00 |8:45:00
[6] | |9:00:00 | |9:00:00 |9:00:00
[7] | | | |9:15:00 |9:15:00
[8] | |9:30:00 | |9:30:00 |9:30:00
[9] | |9:45:00 | |9:45:00 |9:45:00
[10]| |10:00:00| |10:00:00 |10:00:00
[11]| |10:15:00| |10:15:00 |10:15:00
[12]| |10:30:00| |10:30:00 |10:30:00
[13]| |10:45:00| |10:45:00 |10:45:00
[14]|11:00:00|11:00:00|11:00:00 |11:00:00 |11:00:00
[15]| | |11:15:00 | |
[16]| | |11:30:00 | |
[17]| | |11:45:00 | |
[18]|12:00:00| |12:00:00 |12:00:00 |
[19]|12:15:00| |12:15:00 |12:15:00 |
[20]|12:30:00| |12:30:00 |12:30:00 |
[21]|12:45:00| |12:45:00 |12:45:00 |
Option Explicit
Sub てすと()
Dim MyDic As Object
Dim MySh As Worksheet
Dim MyTime As Date
Dim 祝日 As Range
Dim v As Variant
Dim y As Variant
Dim z As Variant
Dim q As Variant
Dim Ti As Variant
Dim MyDay As Long
Dim i As Long
Dim j As Long
Const 間隔 As Long = 15 '分単位で入力してください
Set MySh = ActiveSheet
Set MyDic = CreateObject("Scripting.Dictionary")
MyTime = DateAdd("n", -間隔, "9：00") '開始は9:00です。
ReDim Ti(9 * (60 / 間隔)) '終了は9時間後の 18:00 です。
For j = LBound(Ti) To UBound(Ti)
Ti(j) = DateAdd("n", 間隔, MyTime)
MyTime = Ti(j)
Next
If Not Evaluate("=ISREF(予定表!A1)") Then Sheets.Add.Name = "予定表"
v = Sheets("予定表").Range("A1").CurrentRegion.Resize(, 5).Value
If UBound(v, 1) = 1 Then Exit Sub '予定表にデータがないと終了します
If Not Evaluate("=ISREF(スケジュール!A1)") Then Sheets.Add.Name = "スケジュール"
If Not Evaluate("=ISREF(状況!A1)") Then Sheets.Add.Name = "状況"
If Not Evaluate("=ISREF(祝日!A1)") Then Sheets.Add.Name = "祝日"
With Sheets("祝日")
.Range("A1").Value = CDate(Format(CDate(v(2, 3)), "yyyy/1/1"))
Set 祝日 = .Range("A1").CurrentRegion.Resize(, 1)
End With
MyDic(CDate(Application.WorkDay(DateAdd("d", -1, Format(CDate(v(2, 3)), "yyyy/m/1")), 1, 祝日))) = Ti
MyDay = Day(DateAdd("m", 1, Format(CDate(v(2, 3)), "yyyy/m/1")) - 1)
For i = 1 To MyDay
MyDic(CDate(Application.WorkDay(CDate(Format(CDate(v(2, 3)), "yyyy/m/" & i)), 1, 祝日))) = Ti
Next
For Each y In MyDic.Keys
If Format(y, "yyyy/m") <> Format(v(2, 3), "yyyy/m") Then MyDic.Remove (y)
Next
ReDim w(1 To UBound(Ti) + 2, 1 To MyDic.Count)
y = MyDic.Keys
For j = LBound(y) To UBound(y)
w(1, j + 1) = CLng(y(j))
Next
For i = LBound(v, 1) + 1 To UBound(v, 1)
If MyDic.Exists(CDate(v(i, 3))) Then
q = Application.Match(CLng(v(i, 3)), Application.Index(w, 1, 0), 0)
If Not IsError(q) Then
For j = LBound(Ti) To UBound(Ti)
If (DateAdd("n", -1, CDate(v(i, 4))) < Ti(j)) * (DateAdd("n", -1, CDate(v(i, 5))) > Ti(j)) Then
w(j + 2, q) = w(j + 2, q) + 1
End If
Next
End If
End If
Next
ReDim z(1 To UBound(Ti) + 2, 1 To MyDic.Count)
For j = LBound(y) To UBound(y)
z(1, j + 1) = y(j)
For i = LBound(Ti) To UBound(Ti)
If IsEmpty(w(i + 2, j + 1)) Then z(i + 2, j + 1) = Ti(i)
Next
Next
Application.ScreenUpdating = False
With Sheets("スケジュール")
.Cells.ClearContents
.Cells.FormatConditions.Delete
With .Range("A1")
With .Resize(UBound(z, 1), UBound(z, 2))
.Value = z
.NumberFormat = "h:mm"
End With
.Resize(1, UBound(z, 2)).NumberFormat = "yyyy/m/d(aaa)"
End With
With .Range("A2")
With .Resize(UBound(z, 1), UBound(z, 2))
'***********************************************************************************************
'条件付き書式です。記録して応用してください。使用状況シートの込み具合によって色分けします。
.FormatConditions.Add Type:=xlExpression, Formula1:="=状況!A2=1"
.FormatConditions(1).StopIfTrue = False
With .FormatConditions(1).Interior
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.599963377788629
End With
.FormatConditions.Add Type:=xlExpression, Formula1:="=状況!A2=2"
.FormatConditions(2).StopIfTrue = False
With .FormatConditions(2).Interior
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.599963377788629
End With
.FormatConditions.Add Type:=xlExpression, Formula1:="=状況!A2>=3"
.FormatConditions(3).StopIfTrue = False
With .FormatConditions(3).Interior
.Color = 255
.TintAndShade = 0
End With
'*******************************************************************************************
End With
.CurrentRegion.EntireColumn.AutoFit
End With
.Activate
With ActiveWindow
.SplitColumn = 1
.SplitRow = 1
.FreezePanes = True
End With
End With
With Sheets("状況")
.Cells.Clear
With .Range("A1")
With .Resize(UBound(w, 1), UBound(w, 2))
.Value = w
.NumberFormat = "#"
End With
.Resize(1, UBound(w, 2)).NumberFormat = "yyyy/m/d(aaa)"
.CurrentRegion.EntireColumn.AutoFit
End With
.Activate
With ActiveWindow
.SplitColumn = 1
.SplitRow = 1
.FreezePanes = True
End With
End With
MySh.Activate
Application.ScreenUpdating = True
Set MyDic = Nothing
Set MySh = Nothing
Set 祝日 = Nothing
Erase v, y, z, Ti, w
End Sub
すみません。どうも気に入らないので全面リニューアルです。(^^; 使用した配列を消す方式から状況シートを追加して込み具合をカウントする方式に変更しました。 この状況シートの込み具合によってスケジュールシートの予定が入ってる時間帯を色分けします。 一応、1人でグリーン 2人で黄色 3人以上で赤にしています。 ここは、ほぼほぼ記録なので応用してください。 時間が記入されているところは空いてます。 それから区切る間隔を可変にしました。一応、何分間隔でもいいはずなんですけど？わかりません。 予定は、予定表シートに記入してください。 一応、、テストはしているつもりなんですけど、、まだ、、不具合があるかもしれません。 大きな気持ちで見守っていただけますと幸いです。。。m(__)m では、、では、、、 2021/7/10 14:52 （SoulMan） 2021/07/09(金) 08:43
こんばんは！ お返事がないのは大体お気に召さないことが多いのでちょっと見直しました。 時間帯を9時から18時 平日を追加 祝日シートは無ければ作ります。一応、1月1日を祝日にしています。必要時は間隔を空けないで祝日シートに追加してください。 （SoulMan） 2021/07/09(金) 21:07
なるへそさん
今までOutlookのグループ予定表で確認をしておりましたが、目視で1日単位でしか確認できないのでデータ化したいなと考えたのが今回の質問の発端でした。
Web版のOutlookまで調べていただきありがとうございます。
半平太さん
わかりやすく手順をいただきありがとうございます。
また、VBAのコードもいただきありがとうございます。
まだ作成できておりませんが、時間が空き次第試したいと考えております。
SoulManさん
興味を持っていただきありがとうございます。
また、表形式での書き込みとVBAのコードもいただきありがとうございます。
お気に召さないだなんてとんでもないです。書き込みいただけるだけでもありがたいです！！
こちらもまだ作成できておらず、時間が空き次第試したいと考えております。
せっかく早いレスポンスで回答いただいたのに、私が実施できておらず申し訳ないです。
実施次第、ご報告させていただきます。
（でーえっくす） 2021/07/09(金) 21:15
半平太さん
無事出力できました！
もしまだこの質問を追いかけていてくれていたら以下のコードで具体的になにをしているかご教授いただければ幸いです。（VBAが勉強不足で申し訳ございません...）
For Each cel In WsSche.Range("C2", WsSche.Cells(Rows.Count, "C").End(xlUp))
startPos = Application.Match(CDbl(cel + cel.Offset(, 1)), CheckAry)
endPos = Application.Match(CDbl(cel + cel.Offset(, 2) - adjustSecond), CheckAry)
For t = startPos To endPos
If startPos > 1 And endPos > 1 Then
numFilled(t - 1, Col - 2) = numFilled(t - 1, Col - 2) + 1
End If
Next t
Next cel
SoulManさん
何度も回収して頂きありがとうございます！
最新版も実施し無事出力できております！
3種色分けもあり出てきた結果がカラフルで感動しました。
コード内容までまだ細かく見れていませんが、かなり活用できそうです！
お二方とも、シートに数値で結果を打ち出し、別シートに書式を決めて反映させる形となっており、
自分には思いつかない方法で大変勉強になりました。
もし自分なりに上手くできたものがあった場合は、この質問に再投稿させていただきます！
（でーえっくす） 2021/07/10(土) 16:32
numFilledの配列は、空き枠のマトリックスです。(最後にBackofficeに打ち出される)
各自の予定レコードをみて、このマトリックスのどの枠に該当するかを調べる訳ですけども、 1枠1枠調べる必要はなく、 初めの枠と最後の枠が分かれば、 その中間の枠は有無を言わさず1(人)プラスすれば足ります。
なので開始枠位置と終了枠位置をMatchで求めて、空き枠に1を加算する作業をしている箇所です。
（半平太） 2021/07/10(土) 18:20
まだこの質問を追いかけて下さりありがとうございます！
その中間の枠は有無を言わさず1(人)プラスすれば足りるという説明でスッキリしました。
CDblなども使ったことがなかったので大変勉強になりました！
明日は久しぶりの休みなので、明後日からVBA勉強しなおして自分なりのアレンジも試してみたいと思います！
（でーえっくす） 2021/07/11(日) 17:24
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.