Oudia Secondからスタフに変換してみる
taco_yaki 運転会の最もつら～い作業、それがスタフ作りです。正直これだけでどれだけの睡眠時間が削られたことか......。
我々の運転会では、各回70本程度の列車が設定されていますが、その1本1本に運転時間や細かい指示の書かれた「スタフ」が必要です。
従来はこのスタフ、なんとすべてのデータが手入力でした！
......誇れませんね。
しかし、Oudiaからスタフを生成する術を持っていなかったのです。
そのため毎回6時間から長いと12時間ほどかけて、全列車のスタフを書き上げていました。
手入力ですから、ミスはするし見落としもあるし、なにより面倒くさい......。
そこで何か自動化はできないものか、と考えました。
思い立ったが吉日。まずはgoogle先生に問い合わせです。
まあ安直に。「スタフ 作り方」
ところが......。
検索しても出てきたのは一点モノのスタフばかり。大量生産の方法は出てきません。そりゃそうですよね......。
というわけで自分で作ることにしました。
プログラミングに強いメンバーに相談したところ、「最終出力がExcelならExcelVBAを使うのが良いのでは？」とのこと。
そんなわけでExcelVBAを組んでみました
あれこれ検索して、まずは情報をインポートする部分を作りました。それが以下のソースコードです。VBAどころかプログラミング初心者なので、コードが汚いのは悪しからずということで......。
とりあえず動かしてみた動画がこちら↓
ちなみにこのVBAを動かすには、前準備が必要です。
- ダイヤグラム作成ソフト「Oudia Second」のデータを用意します。
- 出力しない分のダイヤや、空白部分、運用に組み込まれていない列車などを削除（しないとデータがずれます）
- データの拡張子を「.oud2」から「.csv」に変更
- 一回csvファイルをExcelで開き、「マクロ有効有効ブック（.xlsm）」で保存
ここまでやったら、下のVBAを動かします。
追記：以下のVBAは、OudiaSecondV2以降のデータでは正常動作しません。悪しからず......。
[1]データを整理する
Sub 基本情報インポート()
Dim c As Range
Dim i, m, g As Integer
Dim firstAddress, s, b, filename As String
Dim ws As Worksheet, flag As Boolean
'ファイル名(初期シート名)を記入してください
filename = "sakishima_sample"
'シート初期化
For Each ws In Worksheets
If ws.Name = "駅名" Then flag = True
Next ws
If flag = True Then
Worksheets("駅名").Delete ' シート「駅名」を削除
End If
For Each ws In Worksheets
If ws.Name = "種別" Then flag = True
Next ws
If flag = True Then
Worksheets("種別").Delete ' シート「種別」を削除
End If
For Each ws In Worksheets
If ws.Name = "全列車" Then flag = True
Next ws
If flag = True Then
Worksheets("全列車").Delete ' シート「全列車」を削除
End If
'[1]駅名情報だけを抜き出し、新しいワークシートに下り方向で羅列
'駅名記録用シートを追加
Worksheets.Add
ActiveSheet.Name = "駅名"
i = 1
With Worksheets(filename).UsedRange.Columns(1)
Set c = .Find("Ekimei=", LookIn:=xlValues, LookAt:=xlPart) '---(1)Ekimei=から始まる部分を全検索
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
Cells(i, 1) = Mid(c.Value, 8)
Set c = .FindNext(c) '----------------------(2)引数Afterにcを指定し、今見つけたセルの次から検索
i = i + 1
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
g = Worksheets("駅名").Cells(Rows.Count, 1).End(xlUp).Row
i = 0
Do
i = i + 1
Cells(i, 1).Copy Cells(g - i + 1, 3)
Loop Until i = g '----------------------(3)駅名の上り順を生成
'[2]種別情報だけを抜き出し、新しいワークシートに羅列
'種別記録用シートを追加
Worksheets.Add
ActiveSheet.Name = "種別"
i = 1
With Worksheets(filename).UsedRange.Columns(1)
Set c = .Find("Syubetsumei=", LookIn:=xlValues, LookAt:=xlPart) '---(1)Ekimei=から始まる部分を全検索
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
Cells(i, 1) = Mid(c.Value, 13)
Set c = .FindNext(c) '----------------------(2)引数Afterにcを指定し、今見つけたセルの次から検索
i = i + 1
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
'[3-1]列車情報を抜き出し、新しいワークシートに羅列
'列車記録用シートを追加
Worksheets.Add
ActiveSheet.Name = "全列車"
i = 1 '値の初期化
'以下Houkou・Ressya記述部
With Worksheets(filename).UsedRange.Columns(1)
Set c = .Find("Houkou=", LookIn:=xlValues, LookAt:=xlPart) '---(1)Houkou=から始まる部分を全検索
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
c.Resize(1, 1).Copy Destination:=Cells(i + 1, 1)
Cells(i, 1) = "Ressya."
Cells(i + 8, 1) = "."
Set c = .FindNext(c) '----------------------(2)引数Afterにcを指定し、今見つけたセルの次から検索
i = i + 9
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
'以下Syubetsu記述部
i = 1 '値の初期化
With Worksheets(filename).UsedRange.Columns(1)
Set c = .Find("Syubetsu=", LookIn:=xlValues, LookAt:=xlPart) '---(1)Syubetsu=から始まる部分を全検索
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
c.Resize(1, 1).Copy Destination:=Cells(i + 2, 1)
Set c = .FindNext(c) '----------------------(2)引数Afterにcを指定し、今見つけたセルの次から検索
i = i + 9
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
'以下Ressyabangou記述部
i = 1 '値の初期化
With Worksheets(filename).UsedRange.Columns(1)
Set c = .Find("Ressyabangou=", LookIn:=xlValues, LookAt:=xlPart) '---(1)Ressyabangou=から始まる部分を全検索
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
c.Resize(1, 1).Copy Destination:=Cells(i + 3, 1)
Set c = .FindNext(c) '----------------------(2)引数Afterにcを指定し、今見つけたセルの次から検索
i = i + 9
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
'以下Ressyamei記述部
i = 1 '値の初期化
With Worksheets(filename).UsedRange.Columns(1)
Set c = .Find("Ressyamei=", LookIn:=xlValues, LookAt:=xlPart) '---(1)Ressyamei=から始まる部分を全検索
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
c.Resize(1, 1).Copy Destination:=Cells(i + 4, 1)
Set c = .FindNext(c) '----------------------(2)引数Afterにcを指定し、今見つけたセルの次から検索
i = i + 9
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
'以下EkiJikoku記述部
m = 1
i = 1 '値の初期化
With Worksheets(filename).UsedRange.Columns(1)
Set c = .Find("EkiJikoku=", LookIn:=xlValues, LookAt:=xlPart) '---(1)EkiJikoku=から始まる部分を全検索
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
m = Cells(1, i).End(xlToRight).Column
c.Resize(1, m).Copy Destination:= _
Cells(i + 5, 1)
b = Cells(i + 5, 1)
s = Replace(b, "EkiJikoku=", "")
Cells(i + 5, 1) = s
Set c = .FindNext(c) '----------------------(2)引数Afterにcを指定し、今見つけたセルの次から検索
i = i + 9
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
'以下RessyaTrack記述部
m = 1
i = 1 '値の初期化
With Worksheets(filename).UsedRange.Columns(1)
Set c = .Find("RessyaTrack=", LookIn:=xlValues, LookAt:=xlPart) '---(1)RessyaTrack=から始まる部分を全検索
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
m = Cells(1, i).End(xlToRight).Column
c.Resize(1, m).Copy Destination:= _
Cells(i + 6, 1)
b = Cells(i + 6, 1)
s = Replace(b, "RessyaTrack=", "")
Cells(i + 6, 1) = s
Set c = .FindNext(c) '----------------------(2)引数Afterにcを指定し、今見つけたセルの次から検索
i = i + 9
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
'以下OperationNumber記述部
i = 1 '値の初期化
With Worksheets(filename).UsedRange.Columns(1)
Set c = .Find("OperationNumber=", LookIn:=xlValues, LookAt:=xlPart) '---(1)OperationNumber=から始まる部分を全検索
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
c.Resize(1, 1).Copy Destination:=Cells(i + 7, 1)
Set c = .FindNext(c) '----------------------(2)引数Afterにcを指定し、今見つけたセルの次から検索
i = i + 9
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
End Sub
この段で長々と何をやっているかというと、読み込んだデータから「駅名」「種別」「列車情報（種別/行先/各駅時刻/番線など）」の3つのデータを抜き出して、各シートに格納するという作業です。
なお非常に雑な作りなので、一つでも運用外の列車があったり、列車番号が指定されていない列車があったりすると、データがずれてとんでもないことになります。
読み込む際は、必ず全列車「種別」「列車名」「列車番号」「運用番号」が指定されている状態で行ってください。
この作業が終わったら次はいよいよスタフに起こす作業です。(次ページへ続く)
Follow me!
