Oudia Secondからスタフに変換してみる
taco_yaki[2]スタフを生成する
Sub 運用番号検索()
'種別情報だけを抜き出し、新しいワークシートに順番に羅列
Dim c, s As Range
Dim i, j, k, l, m, n, g, h, e, f, n1, n2, n3 As Integer
Dim firstAddress, jikoku, string1, string2, onumber As String
'運用名を""内に記入
onumber = "K04"
'K01用シートを追加
Worksheets.Add
ActiveSheet.Name = onumber
't=val()
i = 3
With Worksheets("全列車").UsedRange.Columns(1)
Set c = .Find(onumber, LookIn:=xlValues, LookAt:=xlPart) '---(1)指定運用の部分を全検索
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚え
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
Cells(2, i - 1) = "所属"
Range(Cells(2, i), Cells(2, i + 5)).Merge
Cells(2, i).HorizontalAlignment = xlCenter
Cells(3, i - 1) = "運用番号"
Cells(3, i) = Mid(c.Value, 17) '----------------------(2)スタフに運用番号印字
Range(Cells(3, i), Cells(3, i + 5)).Merge
Cells(3, i).HorizontalAlignment = xlCenter
Cells(4, i - 1) = "運転者"
Range(Cells(4, i), Cells(4, i + 5)).Merge
Cells(4, i).HorizontalAlignment = xlCenter
Cells(5, i - 1) = "放送番号" '----------------------(3)スタフに放送番号印字するときはここ
Range(Cells(5, i), Cells(5, i + 5)).Merge
Cells(5, i).HorizontalAlignment = xlCenter
Cells(6, i - 1) = "列車番号"
Cells(6, i) = Mid(c.Offset(-4, 0), 14) '----------------------(4)スタフに列番印字
Range(Cells(6, i), Cells(6, i + 5)).Merge
Cells(6, i).HorizontalAlignment = xlCenter
Cells(7, i - 1) = "種別"
Cells(7, i) = Mid(c.Offset(-5, 0), 9) '----------------------(5)スタフに種別印字
Cells(7, i).HorizontalAlignment = xlCenter
l = 0
m = Worksheets("種別").Cells(Rows.Count, 1).End(xlUp).Row
Do
If l = Cells(7, i) Then
Cells(7, i) = Worksheets("種別").Cells(l + 1, 1).Value
End If
l = l + 1
Loop Until l = m
Range(Cells(7, i), Cells(7, i + 5)).Merge
Cells(8, i - 1) = "行先"
Cells(8, i) = Mid(c.Offset(-3, 0), 11) '----------------------(6)スタフに列車名（行先）印字
Range(Cells(8, i), Cells(8, i + 5)).Merge
Cells(8, i).HorizontalAlignment = xlCenter
Cells(9, i) = "着時刻"
Cells(9, i + 1) = "発時刻"
Cells(9, i + 2) = "番線"
Cells(9, i + 3) = "接続"
Cells(9, i + 4) = "交換"
Cells(9, i + 5) = "備考" '----------------------(7)諸元目次印字
g = Worksheets("駅名").Cells(Rows.Count, 1).End(xlUp).Row
If c.Offset(-6, 0) = "Houkou=Kudari" Then
Worksheets("駅名").Cells(1, 1).Resize(g, 1).Copy Destination:=Cells(10, i - 1)
ElseIf c.Offset(-6, 0) = "Houkou=Nobori" Then
Worksheets("駅名").Cells(1, 3).Resize(g, 1).Copy Destination:=Cells(10, i - 1)
End If '----------------------(8)駅名印字
h = 0
Do
h = h + 1
c.Offset(-2, h - 1).Copy Cells(h + 9, i + 1) '----------------------(9)各駅時分仮印字
Cells(h + 9, i + 1) = Replace(Cells(h + 9, i + 1), "1;", "")
Loop Until h = g
h = 0
Do '----------------------(10)時刻の着発分離・通過/経由無し表示処理
h = h + 1
n1 = 1
n2 = 1
jikoku = Cells(h + 9, i + 1)
If InStr(jikoku, "/") Then
string2 = "/"
n1 = InStr(jikoku, string2)
n2 = Len(jikoku)
Cells(h + 9, i) = Left(jikoku, n1 - 1)
Cells(h + 9, i + 1) = Right(jikoku, n2 - n1)
End If
If Cells(h + 9, i + 1).Value = 2 Then
Cells(h + 9, i + 1) = "レ"
ElseIf Cells(h + 9, i + 1).Value = 3 Then
Cells(h + 9, i + 1) = "＝"
End If
Loop Until h = g
h = 0
Do '----------------------(11)時刻コロン挿入処理
h = h + 1
n1 = 1
n2 = 1
n = 0
Do
n = n + 1
jikoku = Cells(h + 9, i + n - 1)
n2 = Len(jikoku)
If n2 = 6 Then
Cells(h + 9, i + n - 1) = Left(jikoku, 2) & ":" & Mid(jikoku, 3, 2) & ":" & Right(jikoku, 2)
ElseIf n2 = 5 Then
Cells(h + 9, i + n - 1) = Left(jikoku, 1) & ":" & Mid(jikoku, 2, 2) & ":" & Right(jikoku, 2)
ElseIf n2 = 4 Then
Cells(h + 9, i + n - 1) = Left(jikoku, 2) & ":" & Right(jikoku, 2)
ElseIf n2 = 3 Then
Cells(h + 9, i + n - 1) = Left(jikoku, 1) & ":" & Right(jikoku, 2)
ElseIf n2 = 2 Then
Cells(h + 9, i + n - 1) = "00:" & Right(jikoku, 2)
End If
Loop Until n = 2
Loop Until h = g
h = 0
Do
h = h + 1
c.Offset(-1, h - 1).Copy Cells(h + 9, i + 2) '----------------------(12)着発番線仮印字
Cells(h + 9, i + 2) = Left(Cells(h + 9, i + 2), 1)
If Cells(h + 9, i + 2) = 0 Then '----------------------(13)着発番線印字
Cells(h + 9, i + 2) = ""
End If
Loop Until h = g
'列幅・配置調整
Columns(i - 1).ColumnWidth = 12.5
Columns(i - 1).HorizontalAlignment = xlCenter
Columns(i).ColumnWidth = 8.38
Columns(i).HorizontalAlignment = xlCenter
Columns(i + 1).ColumnWidth = 8.38
Columns(i + 1).HorizontalAlignment = xlCenter
Columns(i + 2).ColumnWidth = 4.25
Columns(i + 2).HorizontalAlignment = xlCenter
Columns(i + 3).ColumnWidth = 5.75
Columns(i + 3).HorizontalAlignment = xlCenter
Columns(i + 4).ColumnWidth = 5.75
Columns(i + 4).HorizontalAlignment = xlCenter
Columns(i + 5).ColumnWidth = 14.5
Columns(i + 5).HorizontalAlignment = xlCenter
'最後に罫線引き
Range(Cells(2, i - 1), Cells(9 + g, i + 5)).Borders.LineStyle = xlContinuous
With Range(Cells(2, i - 1), Cells(9 + g, i + 5))
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeLeft).Weight = xlMedium
End With
With Range(Cells(4, i - 1), Cells(4, i + 5))
.Borders(xlEdgeBottom).LineStyle = xlDouble
End With
With Range(Cells(8, i - 1), Cells(8, i + 5))
.Borders(xlEdgeBottom).LineStyle = xlDouble
End With
With Range(Cells(9, i), Cells(9 + g, i))
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeLeft).Weight = xlMedium
End With
With Range(Cells(9, i + 2), Cells(9 + g, i + 2))
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeLeft).Weight = xlMedium
End With
Set c = .FindNext(c) '----------------------(2)引数Afterにcを指定し、今見つけたセルの次から検索
i = i + 8
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
End With
End Sub ここでは抜き出した3つのデータを参照しつつ、各運用ごとにスタフを起こす作業をしています。
この辺りで脳がオーバーフローしているので、スタフは最初に指定する1運用しか出力されません。全運用を出すには、毎回運用名を変える必要があります。
まあそれでもだいぶと楽になったので、今回はここまででよいかなと。
なお、以上のプログラムを動かしたことによって損害が発生しても、一切責任は取れませんので、動かす場合は自己責任にて動かすようお願いします。
（執筆：たこたこ焼き）
Follow me!
