Excelでダイヤグラム：上り下り

少し間が空きました。
上り下りの対応をしたいと思います。

データの見出しに、「下り【東横線】」と書いていました。
「【」以降が同じならば、同一の路線とみなすことにします。
下り上りでなくても、A線B線でも、内回り外回りでも気にしません。
下り上りで駅名が同じのチェックは入れましょう。

データはこんな感じです。

これを、こんな図に変換します。

データを読むときに、同じ路線なら路線情報を作らないようにします。

Sub 路線情報作成(路線() As 路線情報, sht As Worksheet)
    rw = 1
    idx = 0
    Do While データ先頭(rw, sht)
        s = sht.Cells(rw, 1).Value
        nm = Mid(s, InStr(s, "【"))
        If idx <> 0 Then
            pos = 路線検索(路線, nm)
        Else
            pos = -1
        End If
        
        reg = False
        If pos = -1 Then
            ReDim Preserve 路線(idx)
            路線(idx).路線名 = nm
            路線(idx).下りデータ行 = rw
            路線(idx).上りデータ行 = -1
            pos = idx
            idx = idx + 1
            reg = True
        Else
            If 路線(pos).上りデータ行 <> -1 Then
                MsgBox "3つめのデータ:" & nm
            End If
            路線(pos).上りデータ行 = rw
        End If
        rw = rw + 1
        cnt = 0
        Do While sht.Cells(rw, 1).Value <> ""
            If reg Then
                ReDim Preserve 路線(pos).駅名(cnt)
                路線(pos).駅名(cnt) = sht.Cells(rw, 1).Value
                If cnt > 0 Then
                    ReDim Preserve 路線(pos).駅間(cnt - 1)
                    路線(pos).駅間(cnt - 1) = sht.Cells(rw, 2).Value
                End If
            Else
                If 路線(pos).駅名(路線(pos).駅数 - cnt - 1) <> sht.Cells(rw, 1).Value Then
                    MsgBox "駅名不一致:" & 路線(pos).駅名(路線(pos).駅数 - cnt - 1) & "/" & sht.Cells(rw, 1).Value
                End If
            End If
            cnt = cnt + 1
            rw = rw + 1
        Loop
        If reg Then
            路線(pos).駅数 = cnt
        Else
            If 路線(pos).駅数 <> cnt Then
                MsgBox "駅数不一致:" & nm
            End If
        End If
    Loop
End Sub

Function 路線検索(路線() As 路線情報, nm)
    路線検索 = -1
    For i = 0 To UBound(路線)
        If 路線(i).路線名 = nm Then
            路線検索 = i
            Exit For
        End If
    Next i
End Function

で、上り下りは、y座標が異なることになります。

Sub スジ(路線() As 路線情報, dataSheet As Worksheet, diagSheet As Worksheet)
    dlta = 0.000001
    drw = 1
    For i = 0 To UBound(路線)
        cl = 3
        Do
            brw = 路線(i).下りデータ行
            irw = 1
            Do While irw < 路線(i).駅数 And dataSheet.Cells(brw + irw, cl).Value = ""
                irw = irw + 1
            Loop
            If dataSheet.Cells(brw + irw, cl).Value = "" Then
                Exit Do
            End If
            
            ox = dataSheet.Cells(brw + irw, cl).Value
            tx = ox
            oy = drw + irw
            irw = irw + 1
            With dataSheet
                clr = .Range(.Cells(brw, cl), .Cells(brw, cl)).Font.Color
            End With
            wgt = 0.5
            If dataSheet.Cells(brw, cl) <> "" Then
                wgt = 1.2
            End If
            
            Do While irw <= 路線(i).駅数
                If dataSheet.Cells(brw + irw, cl).Value = "" Then
                    Exit Do
                End If
                dx = dataSheet.Cells(brw + irw, cl).Value
                tx = tx + TimeSerial(0, 路線(i).駅間(irw - 2), 0)
                If dx <> "↓" Then
                    If tx > dx + dlta Then
                        Call 線描画(diagSheet, ox, oy, dx, drw + irw, clr, wgt)
                        ox = dx
                        tx = dx
                        oy = drw + irw
                    ElseIf tx <= dx - TimeSerial(0, 1, 0) - dlta Then
                        Call 線描画(diagSheet, ox, oy, tx, drw + irw, clr, wgt)
                        ox = dx
                        tx = dx
                        oy = drw + irw
                    End If
                End If
                irw = irw + 1
            Loop
            If oy <> drw + irw - 1 Then
                Call 線描画(diagSheet, ox, oy, dx, drw + irw - 1, clr, wgt)
            End If
            cl = cl + 1
        Loop
        If 路線(i).上りデータ行 <> -1 Then
            cl = 3
            Do
                brw = 路線(i).上りデータ行
                irw = 1
                Do While irw < 路線(i).駅数 And dataSheet.Cells(brw + irw, cl).Value = ""
                    irw = irw + 1
                Loop
                If dataSheet.Cells(brw + irw, cl).Value = "" Then
                    Exit Do
                End If
                
                ox = dataSheet.Cells(brw + irw, cl).Value
                tx = ox
                oy = drw + 路線(i).駅数 - irw + 1
                irw = irw + 1
                With dataSheet
                    clr = .Range(.Cells(brw, cl), .Cells(brw, cl)).Font.Color
                End With
                wgt = 0.5
                If dataSheet.Cells(brw, cl) <> "" Then
                    wgt = 1.2
                End If
                
                Do While irw <= 路線(i).駅数
                    If dataSheet.Cells(brw + irw, cl).Value = "" Then
                        Exit Do
                    End If
                    dx = dataSheet.Cells(brw + irw, cl).Value
                    tx = tx + TimeSerial(0, 路線(i).駅間(路線(i).駅数 - irw), 0)
                    If dx <> "↓" Then
                        If tx > dx + dlta Then
                            Call 線描画(diagSheet, ox, oy, dx, drw + 路線(i).駅数 - irw + 1, clr, wgt)
                            ox = dx
                            tx = dx
                            oy = drw + 路線(i).駅数 - irw + 1
                        ElseIf tx <= dx - TimeSerial(0, 1, 0) - dlta Then
                            Call 線描画(diagSheet, ox, oy, tx, drw + 路線(i).駅数 - irw + 1, clr, wgt)
                            ox = dx
                            tx = dx
                            oy = drw + 路線(i).駅数 - irw + 1
                        End If
                    End If
                    irw = irw + 1
                Loop
                If oy <> drw + 路線(i).駅数 - irw + 2 Then
                    Call 線描画(diagSheet, ox, oy, dx, drw + 路線(i).駅数 - irw + 2, clr, wgt)
                End If
                cl = cl + 1
            Loop
        End If
        drw = drw + 路線(i).駅数 + 2
    Next i
End Sub

かなりゴチャゴチャしてきたので、見直しをした方がよさそうですが、今日はここまでにします。