本記事はヴァル研究所の支援として作成された記事です
今回は、「駅すぱあと API」をExcel VBAから利用して、経費精算に利用する情報を取得してみます。出発駅や経由、到着駅を選んで実行すると、ルートや運賃が表示されますので、経費精算の手間が大幅に軽減されるでしょう。
駅すぱあと APIの基本的な利用方法は前回の経路探索の基本：経費精算を自動化する簡単な方法を参考にしてください。
できあがりイメージ
今回のExcelファイルは、こちらのリポジトリにアップロードしてあります。駅すぱあとAPIのAPIキーは自分が取得したものを利用してください。
駅名・バス停名などの入力補完
今回は全部で4つの経路情報が入力できます。出発駅と到着駅は必須です。入力すると、駅名が入力されたセルに対して、入力補完が行われます。
- 出発駅
- 経由駅1
- 経由駅2
- 到着駅
たとえば 八王子 と入力すると、横浜に一致する駅名やバス停などが選べるようになります。これは駅簡易情報APIを利用しています。
この入力補完用データは、データシートに書き込まれます。
経路検索
出発駅や経由駅を入力した後、 ルート探索 ボタンを押すと、経路探索を実行します。これは経路探索APIを利用しています。
結果は、別のシートが作成され、そこにルート毎に横並びに表示されます。経由した駅名、路線名、そして最終的な運賃が算出されます。
実装について
利用したライブラリ
今回利用したライブラリは以下の通りです。
対応OSについて
今回はWindowsでのみ動作します。URLエンコード時に WorksheetFunction.EncodeURL を使っており、これがWindowsのみ提供されているためです。macOSでもURLエンコードできる関数があれば、macOSでも利用できるはずです（色々試したのですが駄目でした…ご存じの方、教えてください！）
駅名・バス停名などの入力補完機能の実装
入力補完を行う際には、 Worksheet_Change を利用して、セルの入力イベントをチェックします。ここで行っているのは、以下のような内容です。
- 入力されたセルが、出発駅、経由駅1、経由駅2、到着駅のいずれかであるかをチェック
- すでに入力補完（ドロップダウン）があり、そこからの選択であれば何もしない
- 削除された場合は、入力補完のデータ元（データシート）も削除
- 入力された内容で駅名を検索
- データシートに結果を書き込み、入力補完を設定
実際のコードです。以下は、入力イベントの処理です。
Private Sub Worksheet_Change(ByVal Target As Range)
' 範囲外なら何もしない
If Intersect(Target, Range("B1:B4")) Is Nothing Then
Exit Sub
End If
' 行番号
Dim RowIndex As Integer
RowIndex = Target.Row
' 行番号をアルファベットに変換
Dim RowName As String
RowName = Left(Cells(1, (RowIndex * 2) - 1).Address(False, False), 1)
' シート
Dim sheet As Worksheet
Set sheet = Worksheets("データ")
' 最終行を取得
Dim LastRow As Integer
LastRow = sheet.Cells(sheet.Rows.Count, 1).End(xlUp).Row
If LastRow = 1 Then ' 何もデータがない場合は、2行目から
LastRow = 2
End If
' 選択された場合は何もしない
If Not sheet.Range(RowName & "2:" & RowName & LastRow).Find(Target.Value) Is Nothing Then
' 選択された場合
Exit Sub
End If
' 駅の配列が入る構造体
Dim Stations() As Station
' 駅の構造体
Dim s As Station
' インデックス
Dim i As Integer
' 入力値がない（削除した）場合は、入力選択を解除
' データシートの内容も削除
If Target.Value = "" Then
' 入力選択解除
Target.Validation.Delete
sheet.Range(sheet.Cells(2, (RowIndex * 2) - 1), sheet.Cells(LastRow, (RowIndex * 2))).Clear
Exit Sub
End If
' データシートの入力内容を削除
sheet.Range(sheet.Cells(2, (RowIndex * 2) - 1), sheet.Cells(LastRow, (RowIndex * 2))).Clear
' 駅情報を取得
Stations = GetStations(Target.Value)
' 結果を描画する
For i = 0 To UBound(Stations)
s = Stations(i)
sheet.Cells(i + 2, (RowIndex * 2) - 1).Value = s.Name ' 駅名
sheet.Cells(i + 2, (RowIndex * 2)).Value = s.Code ' 駅コード
Next i
' その範囲をリスト入力にする
With Target.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertInformation, _
Operator:=xlBetween, Formula1:="=データ!$" & RowName & "$2:$" & RowName & "$" & UBound(Stations) + 1
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
End Sub
駅名を取得するのは GetStations 関数になります。 YOUR_API_KEY は自分のAPIキーに置き換えてください。
' 駅情報の構造体
Type Station
Name As String ' 駅名
Code As String ' 駅コード
End Type
' 駅名を取得する関数
Function GetStations(Name As String) As Station()
' APIキー
Dim ApiKey As String
ApiKey = "YOUR_API_KEY"
' インデックス
Dim i As Integer
' APIエンドポイント
Dim ApiEndPoint As String
ApiEndPoint = "https://api.ekispert.jp"
' APIパス
Dim ApiPath As String
ApiPath = "/v1/{format}/station/light"
' Webクライアント
Dim Client As New WebClient
Client.BaseUrl = ApiEndPoint
' リクエスト内容の作成
Dim DirectionsRequest As New WebRequest
DirectionsRequest.Method = WebMethod.HttpGet
DirectionsRequest.AddUrlSegment "format", "json"
Dim Query As New Dictionary
Query.Add "key", ApiKey
Query.Add "name", Name
Query.Add "nameMatchType", "partial"
Dim QueryString() As String
ReDim QueryString(UBound(Query.Items))
' クエリ文字列の作成（エンコードも行う）
For i = 0 To UBound(Query.Items)
QueryString(i) = Query.Keys(i) & "=" & WorksheetFunction.EncodeURL(Query.Item(Query.Keys(i)))
Next i
DirectionsRequest.Resource = ApiPath & "?" & Join(QueryString, "&")
' リクエストの実行
Dim Response As WebResponse
Set Response = Client.Execute(DirectionsRequest)
' ステータスコードが200以外の場合はエラー
If Response.StatusCode <> WebStatusCode.Ok Then
Exit Function
End If
' 結果全体を格納するDictionary
Dim ResultSet As Dictionary
Set ResultSet = Response.Data("ResultSet")
' 駅情報を格納する配列
Dim Stations() As Station
ReDim Stations(ResultSet("Point").Count) As Station
' 結果を配列に入れる
Dim Point As Dictionary
i = 0
For Each Point In ResultSet("Point")
Dim s As Station
s.Name = Point("Station")("Name")
s.Code = Point("Station")("code")
Stations(i) = s
i = i + 1
Next Point
' 結果を返す
GetStations = Stations
End Function
APIのレスポンスについては駅簡易情報 - 駅すぱあと API Documents 駅データ・経路検索のWebAPIを参照してください。
経路探索機能の実装
続いて経路探索です。ここではボタンを押されたタイミングで、 SearchRoute 関数が呼ばれます。
' 路線情報
Type Line
Name As String
Type As String
End Type
' 経路のルート情報
Type Route
Line As Line
Boarding As Station
Destination As Station
End Type
' 経路情報
Type Course
Price As Long
Route() As Route
End Type
' 経路探索を行う
Sub SearchRoute()
' 経路入力シート
Dim InputSheet As Worksheet
Set InputSheet = Worksheets("経路入力")
' 入力された駅名とマッチする駅コードを格納する配列
Dim Codes() As String
' インデックス
Dim i As Integer
' 駅コード
Dim Code As String
' 駅名
Dim Name As String
' 出発駅
Dim BoardingName As String
' 到着駅
Dim DestinationName As String
' 出発駅、経路駅1、経路駅2、到着駅の4つ
For i = 1 To 4
' 入力値の取得
Name = InputSheet.Cells(i, 2).Value
' コードを探す
If Name = "" Then
' エラーチェック
If i = 1 Or i = 4 Then
MsgBox ("出発駅、到着駅は必須です")
Exit Sub
End If
GoTo Continue
End If
' 出発駅名（結果シート名に利用する）
If i = 1 Then
BoardingName = Name
End If
' 到着駅名（結果シート名に利用する）
If i = 4 Then
DestinationName = Name
End If
' 駅コードを取得
If (Not Codes) = -1 Then
ReDim Codes(0) As String
Else
ReDim Preserve Codes(UBound(Codes) + 1) As String
End If
Code = GetCode((i * 2) - 1, Name)
If Code = "" Then
MsgBox (i & "行目の名前が見つかりません（" & Name & "）")
Exit Sub
End If
Codes(UBound(Codes)) = Code
Continue: ' 駅名が入っていない場合
Next i
' 経路探索結果が入る配列
Dim Courses() As Course
' 経路探索
Dim Course As Course
' 経路のルート（配列）
Dim Routes() As Route
' ルート
Dim Route As Route
' API検索用
Dim viaList As String
viaList = Join(Codes, ":")
' 経路探索を実行する
Courses = GetRoutes(viaList)
' 結果シート（新しく作成する）
Dim ResultSheet As Worksheet
Set ResultSheet = Worksheets.Add
ResultSheet.Name = BoardingName & "から" & DestinationName
' 出力先の行数
Dim RowIndex As Long
' 出力先の列数
Dim ColumnIndex As Long
ColumnIndex = 1
' 経路の数だけ繰り返す
For i = 0 To UBound(Courses) - 1
Course = Courses(i)
' 結果を出力する
RowIndex = 1
ResultSheet.Cells(RowIndex, ColumnIndex).Value = "ルート" & i + 1
RowIndex = RowIndex + 1
ResultSheet.Cells(RowIndex, ColumnIndex).Value = "合計" & Course.Price & "円"
RowIndex = RowIndex + 2
ResultSheet.Cells(RowIndex, ColumnIndex).Value = "乗車駅"
ResultSheet.Cells(RowIndex, ColumnIndex + 1).Value = "路線名"
ResultSheet.Cells(RowIndex, ColumnIndex + 2).Value = "降車駅"
RowIndex = RowIndex + 1
' ルートの出力
Routes = Course.Route
Dim j As Long
For j = 0 To UBound(Routes) - 1
Route = Routes(j)
ResultSheet.Cells(RowIndex, ColumnIndex).Value = Route.Boarding.Name
ResultSheet.Cells(RowIndex, ColumnIndex + 1).Value = Route.Line.Name
ResultSheet.Cells(RowIndex, ColumnIndex + 2).Value = Route.Destination.Name
RowIndex = RowIndex + 1
Next j
' 列を4つずつずらす
ColumnIndex = ColumnIndex + 4
Next i
End Sub
GetCode 関数は、データシートを使って、駅名と駅コードを変換します。
' 駅名から駅コードを取得する
Function GetCode(ColumnIndex As Integer, Name As String) As String
Dim DataSheet As Worksheet
Set DataSheet = Worksheets("データ") ' 経路入力
' 最終行を取得
Dim LastRow As Integer
LastRow = DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Row
If LastRow = 1 Then ' 何もデータがない場合
LastRow = 2
End If
' 駅名が一致する行を探す
Dim Range As Range
Set Range = DataSheet.Range(DataSheet.Cells(2, ColumnIndex), DataSheet.Cells(LastRow, ColumnIndex)).Find(Name, LookAt:=xlWhole)
If Range Is Nothing Then
' 見つからない場合は空文字を返す
GetCode = ""
Else
' 見つかった場合は、駅コードを返す
GetCode = DataSheet.Cells(Range.Row, Range.Column + 1).Value
End If
End Function
経路探索は GetRoutes 関数で行います。結果は、 Course 構造体（配列）に格納されます。 YOUR_API_KEY は自分のAPIキーに置き換えてください。
' 経路探索を行う
Function GetRoutes(viaList As String) As Course()
' APIキー
Dim ApiKey As String
ApiKey = "YOUR_API_KEY"
' APIエンドポイント
Dim ApiEndPoint As String
ApiEndPoint = "https://api.ekispert.jp"
' APIパス
Dim ApiPath As String
ApiPath = "/v1/{format}/search/course/extreme"
' インデックス
Dim i As Long
' Webクライアント
Dim Client As New WebClient
Client.BaseUrl = ApiEndPoint
' リクエスト内容の作成
Dim DirectionsRequest As New WebRequest
DirectionsRequest.Resource = ApiPath
DirectionsRequest.Method = WebMethod.HttpGet
DirectionsRequest.AddUrlSegment "format", "json"
DirectionsRequest.AddQuerystringParam "key", ApiKey
DirectionsRequest.AddQuerystringParam "viaList", viaList
DirectionsRequest.AddQuerystringParam "searchType", “plain”
' リクエストの実行
Dim Response As WebResponse
Set Response = Client.Execute(DirectionsRequest)
' ステータスコードが200以外の場合はエラー
If Response.StatusCode <> WebStatusCode.Ok Then
Exit Function
End If
' 結果全体を格納するDictionary
Dim ResultSet As Dictionary
Set ResultSet = Response.Data("ResultSet")
' 経路の配列
Dim Courses() As Course
' 経路の数
Dim CourseCount As Long
CourseCount = ResultSet("Course").Count
ReDim Courses(CourseCount) As Course
' インデックス
Dim Index As Long
' 結果をDictinaryの配列に入れる
Dim cs() As Dictionary
SetArray cs, ResultSet, "Course"
For Index = 0 To CourseCount - 1
' 経路情報を取得
Dim Course As Dictionary
Set Course = cs(Index)
' 経路情報を入れる構造体
Dim c As Course
' 運賃情報
Dim Prices() As Dictionary
SetArray Prices, Course, "Price"
' 運賃を取得
c.Price = GetPrice(Prices)
' ルート情報
Dim Route As Dictionary
Set Route = Course("Route")
Dim Points() As Dictionary
Dim Lines() As Dictionary
' ルートの駅情報を取得
SetArray Points, Route, "Point"
' ルートの路線情報を取得
SetArray Lines, Route, "Line"
' ルート情報を入れる配列
Dim Routes() As Route
' 路線の数
Dim LineCount As Long
LineCount = UBound(Lines)
ReDim Routes(LineCount) As Route
' 路線の数だけ繰り返す
i = 0
For i = 0 To LineCount - 1
' 路線情報
Dim r As Route
' 駅情報
Dim s As Dictionary
' 駅情報を取得
Dim p As Dictionary
' 路線情報を取得
r.Line = GetLine(Lines(i))
' 乗車駅
If i = 0 Then
' 最初の駅は出発駅
r.Boarding = GetStation(Points(i)("Station"))
Else
' 2つ目以降は前の駅が乗車駅
r.Boarding = Routes(i - 1).Destination
End If
' 降車駅
r.Destination = GetStation(Points(i + 1)("Station"))
Routes(i) = r
Next i
c.Route = Routes
Courses(Index) = c
Next Index
GetRoutes = Courses
End Function
SetArray 関数は、Dictionaryになっているデータからキーを指定して、配列にして返します。駅すぱあとAPIでは、結果が1件しかない場合はデータが配列になっていないため、その場合は配列に変換しています。
' Dictionaryを配列に変換する
Sub SetArray(ByRef ary() As Dictionary, Data As Dictionary, Key As String)
On Error GoTo NotArray
Dim Index As Long
ReDim ary(Data(Key).Count) As Dictionary
Dim Params As Dictionary
' 配列でない場合は、ここでエラー
For Each Params In Data(Key)
' 配列の場合は順次データを入れ直す
Set ary(Index) = Params
Index = Index + 1
Next Params
Exit Sub
NotArray:
' 配列じゃない場合
ReDim ary(1) As Dictionary
Set ary(0) = Data(Key)
End Sub
GetLine 関数は、路線情報を取得・返却します。
Function GetLine(Params As Dictionary) As Line
Dim Line As Line
Line.Name = Params("Name")
GetLine = Line
End Function
GetStation 関数は、駅情報を取得・返却します。
Function GetStation(Params As Dictionary) As Station
Dim Station As Station
Station.Code = Params("code")
Station.Name = Params("Name")
GetStation = Station
End Function
GetPrice 関数は、運賃情報を取得・返却します。今回は通常運賃のみですが、他にも定期（1〜12ヶ月）の運賃情報なども取得できます。新幹線などを利用した場合は、取得が異なるので注意してください（詳しくは経路探索 - 駅すぱあと API Documents 駅データ・経路検索のWebAPIにて確認してください）。
Function GetPrice(Prices() As Dictionary) As Long
Dim Price As Variant
Dim Index As Long
Index = UBound(Prices)
Dim i As Long
For i = 0 To Index
Set Price = Prices(i)
If Price("kind") = "FareSummary" Then
GetPrice = Val(Price("Oneway"))
Exit Function
End If
Next i
GetPrice = 0
End Function
コードについて
今回のコードはgoofmint/ekispart_routes_demoにアップロードしてあります。実装時の参考にしてください。
まとめ
今回は「駅すぱあと API」を使って、VBAから経路探索および運賃の算出を試しました。経路探索の他にも、「駅すぱあと API」には様々な機能があります。ぜひ、自分のアプリケーションや基幹システムに組み込んで、業務効率化を実現してください。