Excelで乗り継ぎ時刻表の調整を自動で行なう方法

質問

現在、Excelで乗り継ぎ時刻表を作成しているのですが、
バスから電車への乗り換えにかかる時間などにあわせた調整を
以下の作業例のように手動で行なっています。
１．これを関数やマクロなどを用いて手早く処理する方法がありましたら教えてください。
２．また、どう乗り継げば良いのかということを分かりやすく示すために、
　　セルＡ２～Ａ４やＢ２～Ｂ４のような場合は文字列上揃えで結合、
　　セルＥ１～Ｅ２のような場合は文字列下揃えで結合、
　　さらに画像のような場合は文字列中央揃えや
　　一部のセルを結合しないといった調整を行なった上で
　　セルに枠（罫線）をかけるという作業も手動で行なっているのですが、
　　こちらも自動化する方法がありましたら教えてください。

現在の作業例
Ａ列：甲社バス乗車時刻、Ｂ列：甲社バス降車時刻、
Ｃ列：電車発車（乗車）時刻、Ｄ列：電車到着（降車）時刻、Ｅ列：乙社バス乗車時刻・・・
※甲社バスを降りてから電車への乗り換えは３分、
　電車を降りてから乙社バスへの乗り換えは５分を要します。

　調整前
　　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　Ｅ
１　11:50　12:00　12:07　12:27　12:36
２　11:55　12:05　12:10　12:30　12:40
３　12:02　12:12　12:14　12:34　12:45

　調整後

　　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ　　　Ｅ
１　11:50　12:00　12:07　12:27　(空欄)
２　11:55　12:05　12:10　12;30　12:36
３　(空欄) (空欄) 12:14　12:34　12:40
４　(空欄) (空欄) (空欄) (空欄) 12:45
５　12:02　12:12　　　（以下省略）

よろしくお願いします。

回答No.1

mt2008 · ベストアンサー

ちゃんとやろうと思うと、結構面倒ですね。
お望みの形とはちょっと違いますがマクロで作ってみました。
変数宣言も適当ですし、エラー処理も適当なのであくまでもサンプルです。

Sub Sample()
　　Dim dWork As Date
　　Dim dDate As Date
　　nConect1 = 3 '甲バス-電車乗り換え時間（分）
　　nConect2 = 5 '電車-乙バス乗り換え時間（分)
　　nTime = 20 '電車所要時間(分）

　　nDia1 = Cells(Rows.Count, 2).End(xlUp).Row
　　nDia2 = Cells(Rows.Count, 4).End(xlUp).Row
　　nDia3 = Cells(Rows.Count, 5).End(xlUp).Row

　　'各交通機関のダイヤ位置調整
　　Range("A1:D" & nDia3).Insert Shift:=xlDown
　　Range("A1:B" & nDia2).Insert Shift:=xlDown

　　Columns("F:F").Insert Shift:=xlToRight　'作業列の挿入

　　'乙バス
　　For i = 1 To nDia3
　　　　'ソート基準時刻に+2秒(ソート上の都合）
　　　　Cells(i, 6) = Cells(i, 5) + 2 / 24 / 60 / 60
　　Next i

　　'電車
　　For j = 1 To nDia2
　　　　'ソート基準時刻に+1秒(ソート上の都合）
　　　　Cells(j + nDia3, 6) = Cells(j + nDia3, 4) + (nConect2 + 1 / 60) / 24 / 60
　　Next j

　　'甲バス
　　dTrainMax = WorksheetFunction.Max(Range("C:C"))
　　For k = 1 To nDia1
　　　　dDate = Cells(k + nDia3 + nDia2, 2) + nConect1 / 24 / 60
　　　　If dDate <= dTrainMax Then
　　　　　　dWork = fSearchDate(dDate, 3, 0)
　　　　　　dWork = fSearchDate(dWork + (nConect2 + nTime) / 24 / 60, 6, 1)
　　　　Else
　　　　　　dWork = WorksheetFunction.Max(Range("F:F"))
　　　　End If
　　　　Cells(k + nDia3 + nDia2, 6) = dWork + k / 24 / 60 / 60
　　Next k

　　'F列でのソートと作業列の削除
　　Range("A:F").Sort Key1:=Range("F1"), order1:=xlAscending
　　Columns("F:F").Delete Shift:=xlToLeft

End Sub

Function fSearchDate(dDate As Date, nCol As Long, nType As Long) As Date
　　Dim dWork() As Variant
　　Dim dData1 As Date
　　Dim dData2 As Date
　　fSearchDate = 0
　　nTarget = Cells(Rows.Count, nCol).End(xlUp).Row
　　nCount = 0
　　For i = 1 To nTarget
　　　　If nType = 0 Then
　　　　　　'nCol列からdDate以上の中で一番小さい値を返す
　　　　　　dData1 = Cells(i, nCol)
　　　　　　dData2 = dDate
　　　　Else
　　　　　　'nCol列からdDate以下の中で一番大きい値を返す
　　　　　　dData1 = dDate
　　　　　　dData2 = Cells(i, nCol)
　　　　End If

　　　　'誤差の発生を防ぐために一旦「hh:mm:ss」にして比較
　　　　If CDate(Format(dData1, "hh:mm:ss")) >= CDate(Format(dData2, "hh:mm:ss")) Then
　　　　　　ReDim Preserve dWork(nCount)
　　　　　　dWork(nCount) = Cells(i, nCol)
　　　　　　nCount = nCount + 1
　　　　End If
　　Next i
　　If nCount > 0 Then
　　　　If nType = 0 Then
　　　　　　fSearchDate = Application.WorksheetFunction.Min(dWork())
　　　　Else
　　　　　　fSearchDate = Application.WorksheetFunction.Max(dWork())
　　　　End If
　　End If
End Function

お礼

＞お望みの形とはちょっと違いますが
とんでもありません。おかげさまで道が見えてきました。
回答の締め切りはもう少し先にしたいと思いますが、
手探りの状態から脱却できました。
お早い回答をありがとうございました。

補足

思いつきですみませんが、フィルタ機能では無理でしょうか？