【Excel VBA】シフト表からGoogleカレンダーやLINE WORKS対応のiCalendarファイルを作成

勤め先でLINE WORKSを導入しまして、カレンダーで予定の共有をするように推進しています。

ただ、勤務の予定をまとめて入れるのはそこそこ面倒なので、シフト表から取り込みできるファイルを作成できればと考えました。

そういうわけでExcelで作ったシフト表からiCalendar形式のファイルを作成するVBAマクロです。iCalendarに対応していればいけるのでGoogleカレンダーでも利用できます。

スポンサーリンク

マクロの概要

こちらがサンプルファイルです。

https://www.iehohs.com/files/excel-vba-icalendar.zip

今回は「休」のみを登録する仕様です。せめて出勤していない日ぐらいは入れておけよということですね。

こんな感じのシフト表を作りました。シンプルに「休」だけが適当に入っています。

マクロを実行すると、シフト表のファイルと同じ場所に「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ありだと文字化けしたからだと思ったのですが、試しにこの部分の処理をコメントアウトさせて出力しても問題ありませんでした。

コメントの雰囲気的に参考にしたのはこちらのサイトだったと思います。

エクセルVBAでBOM無しのUTF-8でCSVファイルなどを出力する方法
エクセルVBAでデータを様々なファイル形式に書き出す方法についてお伝えしています。今回は、エクセルVBAでBOMなしのUTF-8にてCSVファイルを書き出す方法についてお伝えしていきたいと思います。

コメント時の注意点

  • プログラミングに関するご質問について、コードの書き方はお答えできかねます。
  • スパム対策のため、初投稿の場合はこちらで承認するまでコメント欄に表示されません。
  • 悪質なコメントは未承認のまま削除します。

コメント

タイトルとURLをコピーしました