Oudia Secondからスタフに変換してみる

 運転会の最もつら~い作業、それがスタフ作りです。正直これだけでどれだけの睡眠時間が削られたことか……。
 我々の運転会では、各回70本程度の列車が設定されていますが、その1本1本に運転時間や細かい指示の書かれた「スタフ」が必要です。
 従来はこのスタフ、なんとすべてのデータが手入力でした!
 ……誇れませんね。
 しかし、Oudiaからスタフを生成する術を持っていなかったのです。
 そのため毎回6時間から長いと12時間ほどかけて、全列車のスタフを書き上げていました。
 手入力ですから、ミスはするし見落としもあるし、なにより面倒くさい……。

 そこで何か自動化はできないものか、と考えました。

 思い立ったが吉日。まずはgoogle先生に問い合わせです。
 まあ安直に。「スタフ 作り方」
 ところが……。
 
 検索しても出てきたのは一点モノのスタフばかり。大量生産の方法は出てきません。そりゃそうですよね……。

 というわけで自分で作ることにしました。
 プログラミングに強いメンバーに相談したところ、「最終出力がExcelならExcelVBAを使うのが良いのでは?」とのこと。

そんなわけでExcelVBAを組んでみました

 あれこれ検索して、まずは情報をインポートする部分を作りました。それが以下のソースコードです。VBAどころかプログラミング初心者なので、コードが汚いのは悪しからずということで……。

 とりあえず動かしてみた動画がこちら↓



 ちなみにこのVBAを動かすには、前準備が必要です。

  1. ダイヤグラム作成ソフト「Oudia Second」のデータを用意します。
  2. 出力しない分のダイヤや、空白部分、運用に組み込まれていない列車などを削除(しないとデータがずれます)
  3. データの拡張子を「.oud2」から「.csv」に変更
  4. 一回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!

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です