こんにちは。すごい改善のAitoです。
今回は、VBAを使って身近な問題を解決する一例を紹介していきたいと思います。
今回取り上げるのは「最短経路問題」です。毎日部署内を回らなければならないときや旅行先でどのようにまわるともっとも効率よく楽しめるかなど、最短経路を知ることで仕事もプライベートも役立つことが多いです。
さて、どのようにして作るか、設計から始めましょう。できれば後から使いまわせると嬉しいので、汎用的な設計を意識することにします。ちょっと空でも見上げながら構想を練ります。全部の組み合わせを調べたらいいのかなとか。知識が足りないなと思ったらGoogleなどで「最短経路問題 アルゴリズム」とでも調べてみます。すると「ダイクストラ法」というキーワードが見つかりました。見ていて難しいな、と思う方もいらっしゃると思いますので、もっと簡単にできないか模索してみます。
まず、一番パターン数は多いけれど、難しく考えずに解けるのは全部調べることですよね。そんなことを言うと一部の方からは「アルゴリズムを知らんのか！」と怒られちゃいそうですが、個数が少なければVBAでダイクストラ法を実装するより全部調べた方がきっと早いので全探索を採用します。もし調べたい経路の個数が増えてきた場合はダイクストラ法などのアルゴリズムを検討した方が良いでしょう。では、最初は簡単なところから調べてみましょう。
調べたいものがないことには始まりませんので、課題を設定します。
「沖縄観光をすることになりました。回りたい場所がたくさんあります。どの順番で回るとより効率的に楽しめるでしょうか。」
今回設定した課題は実は私が実際に回るルートを選定するために行った手順をほぼそのまま記載しています。実際の事例に沿っているので、他の場合でも役立つことがあるかなと思います。
最初の関門ですね。リストは作ったけど、どこから手を付けていいかわからない……と悩むかもしれません。この先課題の解決には何が必要なのかを見極める必要があります。交通機関はどうしようかなど悩むかもしれません。しかしそこまで難しく考えなくとも、距離が短ければ移動時間も短いのではないかと予想を立てることはできるはずです。条件が増えた際には簡略化して考えると良いかと思います。ですので、今回は移動距離の総計が最短になるルートが良いルートと条件を設定することにします。
移動距離の合計が最短になるルートを求める際に各観光地同士の距離が必要になります。観光地同士の距離を算出するには、何が必要でしょうか。少し考えてみてください。
……そう、必要なのは位置情報ですよね。具体的には緯度と経度です。こればかりは調べないことにはわからないのでGoogleマップで調べます。
右クリックして出てくるメニューの一番上をクリックすると「クリップボードにコピーされました」と出るので、Excelに貼り付けていきます。私はこんな感じにしました。
このままでは緯度と経度が文字列としてカンマ区切りで入力されてしまっているので、数値として取り出してあげます。いわゆるデータ整形という作業になります。
最新のExcelにはTEXTSPLIT関数が実装されているので、そちらを使います。オートフィルで観光地すべてに適用します。もしご自身のExcelにこの関数がない場合は別の関数で分割する方法を調べてみてください。
このままでは数値が文字列として入力されている状態なので数値として変換してあげましょう。Value関数の中に先ほどのTEXTSPLITを入れ込んであげます。
ここまで作れたら、次は行先の順番の組み合わせを作っていきます。VBAの出番です。すべての場所を一度行くのは順列で表現できます。順列すべてを書き出すことにします。エクセルの神髄というExcel VBAにおける最高のサイトがありますので、悩んだら調べて実装を把握します。今回は2次元配列の扱いをもう少し簡単にできそうだったので、エクセルの神髄を参考にユーザー定義の構造体のようなもの(Type)を使って疑似的に1次元目を拡張可能な二次元配列を作成することにします。はじめにコードを示しますね。
Option Explicit
Type ListOut
Item() As String
End Type
'順列を作って二次元配列として返す関数
Public Sub Permutation(ByRef arr As Variant, ByRef res() As ListOut, Optional n As Long = 0)
Dim i As Long, j As Long
Dim backup As Variant
If (n < UBound(arr)) Then
'その階層のデータを入れ替え
For i = n To UBound(arr)
backup = arr
Dim tmp As String
tmp = arr(n)
arr(n) = arr(i)
arr(i) = tmp
Call Permutation(arr, res, n + 1)
arr = backup
Next
Else
If (Not res) = -1 Then
ReDim res(0)
ReDim res(0).Item(UBound(arr))
Else
ReDim Preserve res(UBound(res) + 1)
ReDim Preserve res(UBound(res)).Item(UBound(arr))
End If
For j = LBound(arr) To UBound(arr)
res(UBound(res)).Item(j) = arr(j)
Next
End If
End Sub
Sub Test()
Dim arr As Variant: arr = Array("A", "B", "C", "D")
Dim output() As ListOut
Call Permutation(arr, output)
Debug.Print (UBound(output) + 1)
Dim i As Long, j As Long, tmp As String
For i = LBound(output) To UBound(output)
tmp = ""
For j = LBound(output(i).Item) To UBound(output(i).Item)
tmp = tmp + output(i).Item(j)
Next
Debug.Print (tmp)
Next
End Sub
なぜこのようなコードになるかは、調べればすぐ出てくると思いますので、解説は省略します。
さて、観光地の個数を調べると、16個の観光地がありますね。16個総当たりでは相当時間がかかると考えられるので、この時点で短くしたいなと考えます。8個くらいならそこまで時間もかからない(8!=40320なので)と考えられるので、行と列の対称性も考慮して8個に分割します。分割する前にどこで分割されるのか、ざっくり位置を見ておくことにしましょう。
A列に入っている地名をコピーしてきてE列にペタッと貼り付けします。経度と緯度と地名を選択した状態で、「挿入」タブの中にある「3Dマップ」→「3D Mapsを開く」をクリックして地図を表示します。もしこの項目がない場合は最新のExcelに更新することをお勧めします。
このようなウィンドウが開くと思うので、沖縄付近まで拡大します。
設定をしていきます。右側に設定項目があるので次のように設定すると項目が視覚的に表示されます。
ここで緯度と経度はどちらを選択してもよいです。
この地図をじーっと見つめます。すると8個目でちょうど南北に分かれることがわかります。ラッキー。これは南から北に移動する場合を考えて、南での最短経路と北での最短経路を考え、南の一番上と北の一番下を最短経路(今回のケースでは自明としてもいいかな)とすることで計算時間を短縮するというものです。ということで、ここからわかることは緯度を基準にして並べ替えると簡単に二分割して考えることができるということですね。先ほどE列にコピーした地名の欄は消去しておきましょう。数式が入ったままだと並べ替えができないので、緯度と経度の欄をコピーして値貼り付けで貼り付けて確定した数値とします。その後に並べ替えを行います。
Sub MakeList1(ByVal s As Long, ByVal e As Long)
Dim list_In() As String
Dim list_Out() As ListOut
Dim i As Long
For i = s To e
ReDim Preserve list_In(i - s)
list_In(i - s) = Cells(i, "A").Value
Next
Call Permutation(list_In, list_Out)
Dim start_col As Long: start_col = Cells(1, Columns.Count).End(xlToLeft).Column + 2
Dim start_row As Long: start_row = 1
For i = start_row To start_row + UBound(list_Out)
Range(Cells(i, start_col), Cells(i, start_col + UBound(list_Out(i - start_row).Item))) = list_Out(i - start_row).Item
Next
End Sub
Sub MakeList2(ByVal s As Long, ByVal e As Long)
Dim list_In() As String
Dim list_Out() As ListOut
Dim i As Long
For i = s To e
ReDim Preserve list_In(i - s)
list_In(i - s) = Cells(i, "A").Value
Next
Call Permutation(list_In, list_Out)
Dim start_col As Long: start_col = Cells(1, Columns.Count).End(xlToLeft).Column + 2
Dim start_row As Long: start_row = 1
For i = start_row To start_row + UBound(list_Out)
Range(Cells(i, start_col), Cells(i, start_col + UBound(list_Out(i - start_row).Item))) = list_Out(i - start_row).Item
Next
End Sub
MakeList1が前半、MakeList2が後半です。動作としては、8!通りをセルに出力し、そのすぐ右横に後半分の8!通りを出力する構造となっています。start_colに値を代入するところで+2していますが、これは後から距離の総和を計算した時の結果を入れるために開けておこうとした意図です。
もうそろそろ終わりが見えてきました。
2点間の距離の算出には上記の式を使用します。
(参考: https://keisan.casio.jp/exec/system/1257670779)
プログラムを書くとこのようになります。言い忘れていましたが、角度はすべてラジアンで計算します。
Function 二点間距離計算(ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double) As Double
Const r As Double = 6378.134
Dim dist As Double
dist = r * WorksheetFunction.Acos(Sin(ToRadians(y1)) * Sin(ToRadians(y2)) + Cos(ToRadians(y1)) * Cos(ToRadians(y2)) * Cos(ToRadians(x2 - x1)))
二点間距離計算 = dist
End Function
Function ToRadians(ByVal degree As Double)
ToRadians = degree * (WorksheetFunction.Pi / 180)
End Function
Sub 距離計算(ByVal start_col As Long, ByVal end_col As Long)
Dim i As Long, j As Long
For i = 1 To Cells(Rows.Count, start_col).End(xlUp).Row
Dim tmp As Double: tmp = 0
For j = start_col To end_col - 1
Dim x1 As Double: x1 = WorksheetFunction.VLookup(Cells(i, j).Value, Range("A:D"), 4, 0)
Dim y1 As Double: y1 = WorksheetFunction.VLookup(Cells(i, j).Value, Range("A:D"), 3, 0)
Dim x2 As Double: x2 = WorksheetFunction.VLookup(Cells(i, j + 1).Value, Range("A:D"), 4, 0)
Dim y2 As Double: y2 = WorksheetFunction.VLookup(Cells(i, j + 1).Value, Range("A:D"), 3, 0)
tmp = tmp + 二点間距離計算(x1, y1, x2, y2)
Next
Cells(i, end_col + 1).Value = tmp
Next
End Sub
最後はここまで作ってきたプロシージャをまとめましょう。
Sub Total()
Application.ScreenUpdating = False
Dim F_Num As Long: F_Num = Range("F1").Column
Range("E:W").ClearContents
Call MakeList1(2, 9)
Call MakeList2(10, 17)
Call 距離計算(F_Num, F_Num + 7)
Call 距離計算(F_Num + 9, F_Num + 16)
End Sub
ようやく順列出力と総距離計算ができるようになりました。実行してみましょう。
少し見にくいですが、このように出力されます。それでは前半と後半に分けて最短経路を調べていきます。シートを二枚追加します。それぞれには「前半」と「後半」と名前を付けておきます。
次に前半シートにはSheet1のF列からN列まで、後半シートにはSheet1のO列からW列をコピーします。そして、前半後半ともに一番右の列(総距離)で並べ替えを行います。
フィルタをかけて前半は開始点を「那覇空港」、終了点を「アメリカンビレッジ」で絞り、後半は開始点を「ビオスの丘」、終了点を「古宇利オーシャンタワー」で絞ります。
最後に前半と後半の最短経路をドッキングして一つの経路にします。この経路で最終的な距離を計算します。プログラムを追加します。
'Sheet1に並べた後に実行
Sub Calc_Distance()
Application.ScreenUpdating = False
Dim F_Num As Long: F_Num = Range("F1").Column
Call 距離計算(F_Num, F_Num + 15)
End Sub
以上で全探索による最短経路の算出は終了です。今回は自動化とは違った観点からVBAを利用したので、ルーティンワークにおいては非効率的な作業も含まれています。一度きりなら多少非効率でも構わないので、大目に見てください(笑)
ここまで全探索での最短経路算出を行ってきましたが、いざ自分で一から算出することはできるようになったでしょうか。大事なのは考え方を知ることで、全部暗記は本質ではありません。自動化ではないVBAの使い方もあると知っていただけたと思いますので、今日はここらで終わります。最後まで読んでいただきありがとうございました。
