先日のブログ
girl.chugakujuken-challenge.work
に書いていた、
偏差値表、地図またはリストから学校名をクリック
最寄り駅から学校までの所要時間、および登校時刻を抽出
目的地と到着時刻をYahoo乗換に転送して検索し、学校までの合計所要時間を表示
乗換時間をゆっくりにしたり、登校時刻にオフセット（何分前）を指定して再検索
ですが、Generative AIであるCodeiumでのコード開発と公開はしないことにしました。
期待されてた方（居ないと思いますが・・・）には申し訳ございません。
なぜかというと、以下のように思ったからです。
Codeiumにコード生成させるため、コメントを送信する
コードが生成される→デバッグする→コメントを追加して洗練させていく
コードや生成プロセスのログがCodeium側に残る
ブログでコードを紹介すると、Codeium側の機械学習でこのブログにヒットする可能性が出る
Codeiumがこのブログにたどり着くと、Codeiumアカウント情報と紐づけできる
Codeium自身、あるいはCodeium利用者が”名寄せ”によって私にたどり着ける
という可能性を考えました。考えすぎかもしれませんが、まだちょっと怖いですね。
そのようなわけで生成AIではなく、私が手を加えたごくありふれたコードで公開します。
美しさは・・・ありません😓
VBAのコマンドボタンクリック関数にコピーするコードは以下の通りです。
'--------------------------------------------------------------------------------------
'一括検索モードかどうかを判断
Dim mode, brows As String
mode = Range("e2").Value
Dim rcnt, init, cur As Long
Dim actrow, actcol As Integer
Dim org, sch, dst, via, desttime, offset, prep, hr, min, transit As String
If mode = "有効" Then
rcnt = Cells(Rows.Count, 1).End(xlUp).Row
init = 5
Range("a5").Activate
Range("f2").Value = "無効"
Else
If ActiveCell.Columns.Count <> 1 Or ActiveCell.Rows.Count <> 1 Then
MsgBox "セルは１つだけ選択して下さい（複数セルは選択できません）", vbExclamation, "エラー"
End If
actrow = ActiveCell.Row 'MsgBox actrow, vbOKOnly, ""
actcol = ActiveCell.Column 'MsgBox actcol, vbOKOnly, ""
If actrow < 5 Or actcol <> 1 Then
MsgBox "学校名が書かれているセルを選択してから計算実行して下さい", vbExclamation, "学校選択エラー"
Exit Sub
End If
rcnt = actrow
init = actrow
End If
brows = Range("f2").Value
If brows = "有効" Then
MsgBox "Yahoo乗換検索結果（ブラウザ画面）は、" & vbCrLf & "毎回手動で閉じて下さい", vbExclamation, "ブラウザは自動で閉じません"
End If
'与えられた条件（駅名、乗換設定など）を抽出する
org = Range("a2").Value
If org = "" Then
MsgBox "出発地が指定されていません", vbExclamation, "エラー"
Exit Sub
End If
transit = Range("b2").Value
Dim traval As String
Select Case True
Case transit Like "急いで"
traval = "1"
Case transit Like "少し急いで"
traval = "2"
Case transit Like "少しゆっくり"
traval = "3"
Case transit Like "ゆっくり"
traval = "4"
End Select
prep = Range("d2").Value
If prep = "" Then
prep = "0"
Else
If Val(prep) > 60 Then
MsgBox "自宅から最寄り駅までの指定可能時間は0～60分までです", vbExclamation, "自宅～最寄り駅エラー"
Exit Sub
End If
End If
offset = Range("c2").Value
If offset = "" Then
offset = "0"
Else
If Val(offset) > 60 Then
MsgBox "到着時刻を早める指定は0～60分までです", vbExclamation, "到着時刻オフセットエラー"
Exit Sub
End If
End If
'ループ処理
For cur = init To rcnt
actrow = ActiveCell.Row
actcol = ActiveCell.Column
sch = ActiveCell.Value 'MsgBox sch, vbOKOnly, ""
If sch = "" Then
MsgBox "学校名が空欄のセルを選択しています", vbExclamation, "学校選択エラー"
Exit Sub
End If
dst = Cells(actrow, actcol + 1).Value 'MsgBox dst, vbOKOnly, ""
desttime = Cells(actrow, actcol + 5).Text 'MsgBox desttime, vbOKOnly, ""
Dim tt As Variant
tt = Split(desttime, ":")
hr = tt(0)
min = tt(1)
Dim nhr, nmin, noff As Integer
nmin = Val(min)
noff = Val(offset)
If nmin < noff Then
nmin = nmin + 60 - noff
min = CStr(nmin)
nhr = Val(hr)
nhr = nhr - 1
hr = CStr(nhr)
End If
Dim dig1, dig2 As String
If Len(hr) > 2 Or Len(hr) < 1 Then
MsgBox "到着時刻の時間指定（時）が不適切です", vbExclamation, "到着時刻の値エラー"
End If
If Len(min) > 2 Or Len(min) < 1 Then
MsgBox "到着時刻の時間指定（分）が不適切です", vbExclamation, "到着時刻の値エラー"
End If
If Len(hr) = 1 Then
hr = "0" & hr
End If
If Len(min) = 1 Then
dig1 = "0"
dig2 = min
Else
dig1 = Left(min, 1)
dig2 = Right(min, 1)
End If
' MsgBox desttime & vbCrLf & hr & "時" & dig1 & dig2 & "分", vbOKOnly, ""
' Chromeを起動する
Dim drv1 As New Selenium.WebDriver
drv1.Start "Chrome"
'検索の日付は2023年7月18日に固定。平日（火曜日）だから
Dim head, mid1, tail As String
head = "https://transit.yahoo.co.jp/search/result?from="
mid1 = "&fromgid=&togid=&flatlon=&tlatlon=&via=&viacode=&y=2023&m=07&d=18&hh="
tail = "&type=4&ticket=ic&expkind=1&userpass=1&ws=" & traval & "&s=0&al=0&shin=0&ex=0&hb=0&lb=1&sr=0"
'Yahoo乗換案内を実行する
drv1.Get head & org & "&to=" & dst & mid1 & hr & "&m1=" & dig1 & "&m2=" & dig2 & tail
Dim restime, leavetime, xpat, commute, alertchk As String
restime = drv1.FindElementByCss("#rsltlst > li:nth-child(1) > dl > dd > ul > li.time").Text
' MsgBox drv1.FindElementByCss("#rsltlst > li:nth-child(1) > dl > dd > ul > li.time").Text
Dim retInStr As Long
retInStr = InStr(1, restime, "]") 'Yahoo乗換で遅延が発生している場合、[!]が文字列に追加されるため
If retInStr > 0 Then
' MsgBox restime, 0, "Original"
restime = mid(restime, retInStr + 1)
' MsgBox restime, 0, "Modified"
End If
xpat = "//*[@id=" & Chr(34) & "route01" & Chr(34) & "]/dl/dd[2]/ul/li[2]/p/a"
drv1.Wait 100
drv1.FindElementByXPath(xpat).Click
drv1.Wait 500 'クリック後にYahoo乗換上のJAVAスクリプト処理が完了するのを待つため
drv1.FindElementByCss("#route01 > dl > dd.option > div.detail.commuterPass > dl > dt > form > select").AsSelect.SelectByValue ("HighSchool,0")
drv1.Wait 500 'クリック後にYahoo乗換上のリストボックス選択が完了するのを待つため
commute = drv1.FindElementByCss("#route01 > dl > dd.option > div.detail.commuterPass > dl > dd > ul > li:nth-child(3) > span").Text
drv1.Wait 500
If brows = "有効" Then
Dim res
While res <> vbYes
res = MsgBox("ブラウザを閉じましたか？" & vbCrLf & "（あるいは、ブラウザを閉じていいいですか？" _
, vbQuestion + vbYesNo, "ブラウザ終了確認")
Wend
End If
drv1.Quit
Dim resvar As Variant
resvar = Split(restime, "→")
leavetime = resvar(0)
Dim ltime, tmpt As Date
ltime = TimeValue(leavetime & ":00")
tmpt = DateAdd("n", -1 * Val(prep), ltime)
leavetime = CDate(tmpt)
leavetime = Format(leavetime, "hh:mm")
Cells(actrow, actcol + 6).Value = leavetime
Cells(actrow, actcol + 7).Value = commute
' MsgBox "出発時刻は" & leavetime & "です", 0
' MsgBox "6か月定期券代（通学）は" & commute & "です", 0
Cells(actrow + 1, actcol).Activate
Next
Range("a5").Activate
ThisWorkbook.Save
