勤め先でLINE WORKSを導入しまして、カレンダーで予定の共有をするように推進しています。
ただ、勤務の予定をまとめて入れるのはそこそこ面倒なので、シフト表から取り込みできるファイルを作成できればと考えました。
そういうわけでExcelで作ったシフト表からiCalendar形式のファイルを作成するVBAマクロです。iCalendarに対応していればいけるのでGoogleカレンダーでも利用できます。
マクロの概要
今回は「休」のみを登録する仕様です。せめて出勤していない日ぐらいは入れておけよということですね。
こんな感じのシフト表を作りました。シンプルに「休」だけが適当に入っています。
マクロを実行すると、シフト表のファイルと同じ場所に「iCalendarフォルダ\yyyymm」というフォルダを作成し、職員それぞれのicsファイルが作成されます。
作成されたicsファイルを職員が自身のカレンダーに取り込むことで「休」だけは自動的に入力されるという流れです。
コード (VBA)
Sub icsファイル作成()
Dim rowStart As Integer
Dim rowEnd As Integer
Dim colStart As Integer
Dim colEnd As Integer
Dim shiftArray() As String
Dim memberArray() As String
Dim setYear As String
Dim setMonth As String
Dim setDay As String
Dim endDate As Date
Dim endYear As String
Dim endMonth As String
Dim endDay As String
Dim holidayStr As String
Dim icsFolderPath As String
Dim icsFilePath As String
Dim adoSt As Object
headRow = 1
headCol = 1
rowStart = 3
colStart = 3
rowEnd = Cells(rowStart, headCol).End(xlDown).Row
colEnd = Cells(headRow, colStart).End(xlToRight).Column
setYear = Replace(Cells(headRow, headCol).Value, "年", "")
setMonth = Replace(Cells(headRow, headCol + 1).Value, "月", "")
If Len(setMonth) = 1 Then
setMonth = "0" & setMonth
End If
holidayStr = "休"
ReDim shiftArray(rowEnd - rowStart, colEnd - colStart)
ReDim memberArray(rowEnd - rowStart)
For y = 0 To UBound(shiftArray, 1)
memberArray(y) = Cells(rowStart + y, headCol).Value
For x = 0 To UBound(shiftArray, 2)
shiftArray(y, x) = Cells(rowStart + y, colStart + x).Value
Next x
Next y
icsFolderPath = ThisWorkbook.Path & "\" & "iCalendarフォルダ"
If Dir(icsFolderPath, vbDirectory) = "" Then
MkDir icsFolderPath
End If
icsFolderPath = icsFolderPath & "\" & setYear & setMonth
If Dir(icsFolderPath, vbDirectory) = "" Then
MkDir icsFolderPath
End If
For y = 0 To UBound(shiftArray, 1)
setName = memberArray(y)
'icsファイルを作成
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.WriteText "BEGIN:VCALENDAR", 1
.WriteText "PRODID:iEhohs.com", 1
.WriteText "VERSION:2.0", 1
.WriteText "CALSCALE:GREGORIAN", 1
.WriteText "METHOD:PUBLISH", 1
.WriteText "BEGIN:VTIMEZONE", 1
.WriteText "TZID:Asia/Tokyo", 1
.WriteText "TZURL:http://tzurl.org/zoneinfo-outlook/Asia/Tokyo", 1
.WriteText "X-LIC-LOCATION:Asia/Tokyo", 1
.WriteText "BEGIN:STANDARD", 1
.WriteText "TZNAME:JST", 1
.WriteText "TZOFFSETFROM:+0900", 1
.WriteText "TZOFFSETTO:+0900", 1
.WriteText "DTSTART:19700101T000000", 1
.WriteText "END:STANDARD", 1
.WriteText "END:VTIMEZONE", 1
For x = 0 To UBound(shiftArray, 2)
setDay = x + 1
If Len(setDay) = 1 Then
setDay = "0" & setDay
End If
If shiftArray(y, x) = holidayStr Then
'「休」の日はicsファイルに入力
.WriteText "BEGIN:VEVENT", 1
.WriteText "DTSTART;VALUE=DATE:" & setYear & setMonth & setDay, 1
endDate = DateAdd("d", 1, CDate(setYear & "/" & setMonth & "/" & setDay))
endYear = Year(endDate)
endMonth = Month(endDate)
If Len(endMonth) = 1 Then
endMonth = "0" & endMonth
End If
endDay = Day(endDate)
If Len(endDay) = 1 Then
endDay = "0" & endDay
End If
.WriteText "DTEND;VALUE=DATE:" & endYear & endMonth & endDay, 1
.WriteText "SUMMARY:" & holidayStr, 1
.WriteText "END:VEVENT", 1
End If
Next x
.WriteText "END:VCALENDAR", 0 'icsファイル最終行
'UTF-8をBOMなしにする
.Position = 0 'ストリームの位置を0にする
.Type = 1 'データの種類をバイナリデータに変更
.Position = 3 'ストリームの位置を3にする
Dim byteData() As Byte '一時格納用
byteData = .Read 'ストリームの内容を一時格納用変数に保存
.Close '一旦ストリームを閉じる（リセット）
.Open 'ストリームを開く
.Write byteData 'ストリームに一時格納したデータを流し込む
'icsファイルを保存
icsFileName = icsFolderPath & "\" & setName & ".ics"
.SaveToFile icsFileName, 2
.Close
End With
Next y
MsgBox icsFolderPath & vbCrLf & vbCrLf & "上記のフォルダに各職員ごとのicsファイルを作成しました。", vbInformation, "icsファイル作成完了"
End Subシフト表のレイアウトの情報を入力して、配列に入れたシフト表の入力情報を元に判定させるというところは特に何の変哲もないので解説は割愛です。
icsファイルの仕様
icsファイルはこのような「BEGIN」と「END」の入れ子の構造になっています。その中に必要な情報を入れていくという感じですね。
BEGIN:VCALENDAR
PRODID:iEhohs.com
VERSION:2.0
CALSCALE:GREGORIAN
METHOD:PUBLISH
BEGIN:VTIMEZONE
TZID:Asia/Tokyo
TZURL:http://tzurl.org/zoneinfo-outlook/Asia/Tokyo
X-LIC-LOCATION:Asia/Tokyo
BEGIN:STANDARD
TZNAME:JST
TZOFFSETFROM:+0900
TZOFFSETTO:+0900
DTSTART:19700101T000000
END:STANDARD
END:VTIMEZONE
BEGIN:VEVENT
DTSTART;VALUE=DATE:20220501
DTEND;VALUE=DATE:20220502
SUMMARY:休
END:VEVENT
END:VCALENDAR「END:VTIMEZONE」まではこれだけ入れておいたら動いたのでとりあえず書いておいたらいいかな、と。
PRODIDについては適当でいいと思います。今回は僕が作ったファイルということで「iEhohs.com」と書いておきました。
「休」の情報は「BEGIN:VEVENT」と「END:VEVENT」の間に書きます。今回は終日の予定を入れる形になるので、DTSTARTで当日を、DTENDで翌日の日付を指定します。
SUMMARYはカレンダーに表示する予定名です。
これを「休」の数だけ繰り返し記述して、最後に「END:VCALEMDAR」で閉じればOKです。
BOMなしのUTF-8で出力する
Excelでテキストファイルを作成すると基本的にShift JISで作成するのですが、こいつをUTF-8に変換するためにADODB.Streamを使用します。
ただ、それだけではBOM付きのUTF-8になってしまうので、BOMなしにするためにいろいろやってます。
'UTF-8をBOMなしにする
.Position = 0 'ストリームの位置を0にする
.Type = 1 'データの種類をバイナリデータに変更
.Position = 3 'ストリームの位置を3にする
Dim byteData() As Byte '一時格納用
byteData = .Read 'ストリームの内容を一時格納用変数に保存
.Close '一旦ストリームを閉じる（リセット）
.Open 'ストリームを開く
.Write byteData 'ストリームに一時格納したデータを流し込むただ、この処理を行った理由が思い出せません^^;
おそらくBOMありだと文字化けしたからだと思ったのですが、試しにこの部分の処理をコメントアウトさせて出力しても問題ありませんでした。
コメントの雰囲気的に参考にしたのはこちらのサイトだったと思います。
コメント