覚書
Option Explicit
Public Sub 飛行作業線表生成()
Const INPUT_SHEET_NAME As String = "入力データ"
Const OUTPUT_SHEET_NAME As String = "出力データ"
Const DATA_FIRST_ROW As Long = 61
Const OUT_FIRST_ROW As Long = 26
Const OUT_ROW_STEP As Long = 4
Const DEFAULT_TEMPLATE_BLOCKS As Long = 6
Const DAY_START_MIN As Long = 420 ' 07:00
Const DAY_END_MIN As Long = 1320 ' 22:00
Dim wsIn As Worksheet
Dim wsOut As Worksheet
Dim dicAircraft As Object
Dim dicOutRow As Object
Dim keys As Variant
Dim i As Long
Dim r As Long
Dim ac As String
Dim dataLastRow As Long
Dim originLeft As Double
Dim nextHourLeft As Double
Dim minuteWidth As Double
Dim requiredBlocks As Long
Dim existingBlocks As Long
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wsIn = ResolveInputSheet(ThisWorkbook, INPUT_SHEET_NAME)
Set wsOut = ResolveOutputSheet(ThisWorkbook, OUTPUT_SHEET_NAME)
If wsIn Is Nothing Then
Err.Raise vbObjectError + 1000, , "入力データ用のシートを特定できませんでした。"
End If
If wsOut Is Nothing Then
Err.Raise vbObjectError + 1001, , "出力データ用のシートを特定できませんでした。"
End If
dataLastRow = GetLastInputRow(wsIn, DATA_FIRST_ROW)
Set dicAircraft = CreateObject("Scripting.Dictionary")
Set dicOutRow = CreateObject("Scripting.Dictionary")
For r = DATA_FIRST_ROW To dataLastRow
If IsValidRecord(wsIn, r) Then
ac = Trim$(CStr(wsIn.Cells(r, "D").Value))
If ac <> "" Then
If Not dicAircraft.Exists(ac) Then
dicAircraft.Add ac, ac
End If
End If
End If
Next r
If dicAircraft.Count = 0 Then
MsgBox "入力データが見つかりませんでした。", vbExclamation
GoTo ExitProc
End If
requiredBlocks = dicAircraft.Count
existingBlocks = GetStoredBlockCount(ThisWorkbook, DEFAULT_TEMPLATE_BLOCKS)
ClearGeneratedShapes wsOut
If requiredBlocks > existingBlocks Then
EnsureOutputCapacity wsOut, OUT_FIRST_ROW, OUT_ROW_STEP, DEFAULT_TEMPLATE_BLOCKS, existingBlocks, requiredBlocks
existingBlocks = requiredBlocks
SetStoredBlockCount ThisWorkbook, existingBlocks
Else
If existingBlocks < DEFAULT_TEMPLATE_BLOCKS Then
existingBlocks = DEFAULT_TEMPLATE_BLOCKS
End If
SetStoredBlockCount ThisWorkbook, existingBlocks
End If
ClearAircraftLabels wsOut, OUT_FIRST_ROW, OUT_ROW_STEP, existingBlocks
keys = dicAircraft.Keys
SortVariantArray keys
For i = LBound(keys) To UBound(keys)
ac = CStr(keys(i))
dicOutRow.Add ac, OUT_FIRST_ROW + (i * OUT_ROW_STEP)
wsOut.Range("C" & (OUT_FIRST_ROW + (i * OUT_ROW_STEP))).Value = ac
Next i
originLeft = wsOut.Range("J1").Left
nextHourLeft = wsOut.Range("P1").Left
minuteWidth = (nextHourLeft - originLeft) / 60#
For r = DATA_FIRST_ROW To dataLastRow
If IsValidRecord(wsIn, r) Then
ac = Trim$(CStr(wsIn.Cells(r, "D").Value))
If dicOutRow.Exists(ac) Then
Dim sMin As Long
Dim eMin As Long
Dim eteHour As Double
Dim leftPts As Double
Dim widthPts As Double
Dim outRow As Long
Dim topY As Double, topH As Double
Dim mainY As Double, mainH As Double
Dim noteY As Double, noteH As Double
Dim crewText As String
Dim missText As String
Dim eteText As String
Dim noteText As String
Dim kindText As String
Dim fillColor As Long
sMin = HHMMToMinutes(wsIn.Cells(r, "H").Value)
eMin = HHMMToMinutes(wsIn.Cells(r, "L").Value)
If sMin >= 0 Then
If eMin <= sMin Then
eteHour = GetNumericValue(wsIn.Cells(r, "P").Value)
If eteHour > 0 Then
eMin = sMin + CLng(eteHour * 60#)
End If
End If
If eMin > sMin Then
If sMin < DAY_END_MIN And eMin > DAY_START_MIN Then
If sMin < DAY_START_MIN Then sMin = DAY_START_MIN
If eMin > DAY_END_MIN Then eMin = DAY_END_MIN
outRow = CLng(dicOutRow(ac))
leftPts = originLeft + ((sMin - DAY_START_MIN) * minuteWidth) + 1
widthPts = ((eMin - sMin) * minuteWidth) - 2
If widthPts < 36 Then widthPts = 36
topY = wsOut.Rows(outRow).Top + 1
topH = wsOut.Rows(outRow).Height - 2
mainY = wsOut.Rows(outRow + 1).Top + 1
mainH = wsOut.Rows(outRow + 1).Height - 2
noteY = wsOut.Rows(outRow + 2).Top + 1
noteH = wsOut.Rows(outRow + 2).Height + wsOut.Rows(outRow + 3).Height - 2
crewText = BuildCrewText(wsIn, r)
missText = Trim$(CStr(wsIn.Cells(r, "BQ").Text))
eteText = GetEteText(wsIn.Cells(r, "P").Value)
noteText = BuildRemarksText(wsIn, r, dataLastRow)
kindText = GetKindText(wsIn, r)
fillColor = GetLineColor(kindText)
AddFreeTextBox wsOut, _
"senpyo_top_" & CStr(r), _
leftPts, topY, widthPts, topH, _
crewText, 6.5, False, _
msoAlignLeft, msoAnchorMiddle
AddMainBox wsOut, _
"senpyo_main_" & CStr(r), _
leftPts, mainY, widthPts, mainH, _
missText & " " & eteText, fillColor
AddFreeTextBox wsOut, _
"senpyo_note_" & CStr(r), _
leftPts, noteY, widthPts, noteH, _
noteText, 6, True, _
msoAlignLeft, msoAnchorTop
End If
End If
End If
End If
End If
Next r
ExitProc:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "エラー: " & Err.Description, vbCritical
End Sub
Private Function ResolveInputSheet(ByVal wb As Workbook, ByVal preferredName As String) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ResolveInputSheet = wb.Worksheets(preferredName)
On Error GoTo 0
If Not ResolveInputSheet Is Nothing Then Exit Function
For Each ws In wb.Worksheets
If HasInputSignature(ws) Then
Set ResolveInputSheet = ws
Exit Function
End If
Next ws
End Function
Private Function ResolveOutputSheet(ByVal wb As Workbook, ByVal preferredName As String) As Worksheet
Dim ws As Worksheet
Dim nm As String
On Error Resume Next
Set ResolveOutputSheet = wb.Worksheets(preferredName)
On Error GoTo 0
If Not ResolveOutputSheet Is Nothing Then Exit Function
For Each ws In wb.Worksheets
nm = Replace(Trim$(ws.Name), " ", "")
If UCase$(nm) = "SHEET2" Then
Set ResolveOutputSheet = ws
Exit Function
End If
Next ws
For Each ws In wb.Worksheets
If HasOutputSignature(ws) Then
Set ResolveOutputSheet = ws
Exit Function
End If
Next ws
End Function
Private Function HasInputSignature(ByVal ws As Worksheet) As Boolean
Dim score As Long
score = 0
If SheetContainsText(ws, "NO") Then score = score + 1
If SheetContainsText(ws, "A/C") Then score = score + 1
If SheetContainsText(ws, "ETD") Then score = score + 1
If SheetContainsText(ws, "ETA") Then score = score + 1
If SheetContainsText(ws, "ETE") Then score = score + 1
HasInputSignature = (score >= 4)
End Function
Private Function HasOutputSignature(ByVal ws As Worksheet) As Boolean
Dim score As Long
score = 0
If SheetContainsText(ws, "機番") Then score = score + 1
If SheetContainsText(ws, "０７００") Or SheetContainsText(ws, "0700") Then score = score + 1
If SheetContainsText(ws, "０８００") Or SheetContainsText(ws, "0800") Then score = score + 1
HasOutputSignature = (score >= 2)
End Function
Private Function SheetContainsText(ByVal ws As Worksheet, ByVal searchText As String) As Boolean
Dim f As Range
On Error Resume Next
Set f = ws.Cells.Find(What:=searchText, _
After:=ws.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
SheetContainsText = Not f Is Nothing
End Function
Private Function GetLastInputRow(ByVal ws As Worksheet, ByVal minimumRow As Long) As Long
Dim cols As Variant
Dim i As Long
Dim r As Long
Dim lastRow As Long
cols = Array("B", "D", "H", "L", "P", "BQ", "BY")
lastRow = minimumRow
For i = LBound(cols) To UBound(cols)
r = ws.Cells(ws.Rows.Count, cols(i)).End(xlUp).Row
If r > lastRow Then lastRow = r
Next i
If lastRow < minimumRow Then lastRow = minimumRow
GetLastInputRow = lastRow
End Function
Private Function IsValidRecord(ByVal ws As Worksheet, ByVal r As Long) As Boolean
Dim ac As String
Dim etd As Long
ac = Trim$(CStr(ws.Cells(r, "D").Value))
etd = HHMMToMinutes(ws.Cells(r, "H").Value)
If ac = "" Then Exit Function
If etd < 0 Then Exit Function
IsValidRecord = True
End Function
Private Function HHMMToMinutes(ByVal v As Variant) As Long
Dim s As String
Dim hh As Long
Dim mm As Long
On Error GoTo ErrHandler
If IsDate(v) Then
HHMMToMinutes = Hour(CDate(v)) * 60 + Minute(CDate(v))
Exit Function
End If
s = Trim$(CStr(v))
s = Replace(s, ":", "")
s = Replace(s, "：", "")
If s = "" Then
HHMMToMinutes = -1
Exit Function
End If
If Not IsNumeric(s) Then
HHMMToMinutes = -1
Exit Function
End If
s = Right$("0000" & s, 4)
hh = CLng(Left$(s, 2))
mm = CLng(Right$(s, 2))
If hh < 0 Or hh > 23 Or mm < 0 Or mm > 59 Then
HHMMToMinutes = -1
Else
HHMMToMinutes = hh * 60 + mm
End If
Exit Function
ErrHandler:
HHMMToMinutes = -1
End Function
Private Function BuildCrewText(ByVal ws As Worksheet, ByVal r As Long) As String
Dim cols As Variant
Dim i As Long
Dim txt As String
Dim buf As String
cols = Array("T", "AA", "AH", "AO", "AV", "BC")
For i = LBound(cols) To UBound(cols)
txt = Trim$(CStr(ws.Cells(r, cols(i)).Text))
If txt <> "" Then
If buf <> "" Then buf = buf & " "
buf = buf & txt
End If
Next i
BuildCrewText = buf
End Function
Private Function BuildRemarksText(ByVal ws As Worksheet, ByVal r As Long, ByVal lastRow As Long) As String
Dim rr As Long
Dim txt As String
Dim buf As String
Dim endRow As Long
endRow = r + 3
If endRow > lastRow Then endRow = lastRow
For rr = r To endRow
txt = Trim$(CStr(ws.Cells(rr, "BY").Text))
If txt <> "" Then
If buf <> "" Then buf = buf & vbLf
buf = buf & txt
End If
Next rr
BuildRemarksText = buf
End Function
Private Function GetKindText(ByVal ws As Worksheet, ByVal r As Long) As String
GetKindText = Trim$(CStr(ws.Cells(r, "B").Text))
End Function
Private Function GetLineColor(ByVal kindText As String) As Long
kindText = Trim$(kindText)
Select Case True
Case kindText Like "訓*"
GetLineColor = RGB(0, 112, 192)
Case kindText Like "試*"
GetLineColor = RGB(255, 0, 0)
Case kindText Like "要*"
GetLineColor = RGB(255, 255, 0)
Case UCase$(kindText) = "GND"
GetLineColor = RGB(255, 255, 255)
Case Else
GetLineColor = RGB(255, 255, 255)
End Select
End Function
Private Function GetEteText(ByVal v As Variant) As String
If Trim$(CStr(v)) = "" Then
GetEteText = ""
ElseIf IsNumeric(v) Then
GetEteText = Format$(CDbl(v), "0.0")
Else
GetEteText = Trim$(CStr(v))
End If
End Function
Private Function GetNumericValue(ByVal v As Variant) As Double
If IsNumeric(v) Then
GetNumericValue = CDbl(v)
Else
GetNumericValue = 0
End If
End Function
Private Sub ClearAircraftLabels(ByVal ws As Worksheet, ByVal firstRow As Long, ByVal rowStep As Long, ByVal blockCount As Long)
Dim i As Long
For i = 0 To blockCount - 1
ws.Range("C" & (firstRow + i * rowStep)).Value = ""
Next i
End Sub
Private Sub ClearGeneratedShapes(ByVal ws As Worksheet)
Dim i As Long
For i = ws.Shapes.Count To 1 Step -1
If Left$(ws.Shapes(i).Name, 7) = "senpyo_" Then
ws.Shapes(i).Delete
End If
Next i
End Sub
Private Sub EnsureOutputCapacity(ByVal ws As Worksheet, _
ByVal firstRow As Long, _
ByVal rowStep As Long, _
ByVal templateBlocks As Long, _
ByVal currentBlocks As Long, _
ByVal requiredBlocks As Long)
Dim sourceStartRow As Long
Dim destStartRow As Long
Dim blockIndex As Long
If requiredBlocks <= currentBlocks Then Exit Sub
sourceStartRow = firstRow + (templateBlocks - 1) * rowStep
For blockIndex = currentBlocks To requiredBlocks - 1
destStartRow = firstRow + blockIndex * rowStep
ws.Rows(sourceStartRow & ":" & sourceStartRow + rowStep - 1).Copy
ws.Rows(destStartRow & ":" & destStartRow + rowStep - 1).Insert Shift:=xlDown
Application.CutCopyMode = False
ws.Range("C" & destStartRow).Value = ""
Next blockIndex
End Sub
Private Function GetStoredBlockCount(ByVal wb As Workbook, ByVal defaultCount As Long) As Long
Dim nm As Name
Dim v As Variant
On Error Resume Next
Set nm = wb.Names("_SenpyoBlockCount")
On Error GoTo 0
If nm Is Nothing Then
GetStoredBlockCount = defaultCount
Exit Function
End If
On Error Resume Next
v = Evaluate(nm.RefersTo)
On Error GoTo 0
If IsNumeric(v) Then
If CLng(v) >= defaultCount Then
GetStoredBlockCount = CLng(v)
Else
GetStoredBlockCount = defaultCount
End If
Else
GetStoredBlockCount = defaultCount
End If
End Function
Private Sub SetStoredBlockCount(ByVal wb As Workbook, ByVal blockCount As Long)
On Error Resume Next
wb.Names("_SenpyoBlockCount").Delete
On Error GoTo 0
wb.Names.Add Name:="_SenpyoBlockCount", RefersTo:="=" & CStr(blockCount)
End Sub
Private Sub AddMainBox(ByVal ws As Worksheet, _
ByVal shpName As String, _
ByVal leftPts As Double, _
ByVal topPts As Double, _
ByVal widthPts As Double, _
ByVal heightPts As Double, _
ByVal textValue As String, _
ByVal fillColor As Long)
Dim shp As Shape
Set shp = ws.Shapes.AddShape(msoShapeRectangle, leftPts, topPts, widthPts, heightPts)
shp.Name = shpName
shp.Placement = xlMoveAndSize
With shp
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 0.75
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = fillColor
.Fill.Solid
With .TextFrame2
.TextRange.Text = textValue
.TextRange.ParagraphFormat.Alignment = msoAlignLeft
.VerticalAnchor = msoAnchorMiddle
.MarginLeft = 3
.MarginRight = 1
.MarginTop = 1
.MarginBottom = 1
.WordWrap = msoTrue
.AutoSize = msoAutoSizeTextToFitShape
With .TextRange.Font
.Size = 11
.Bold = msoTrue
.Fill.ForeColor.RGB = RGB(0, 0, 0)
End With
End With
End With
End Sub
Private Sub AddFreeTextBox(ByVal ws As Worksheet, _
ByVal shpName As String, _
ByVal leftPts As Double, _
ByVal topPts As Double, _
ByVal widthPts As Double, _
ByVal heightPts As Double, _
ByVal textValue As String, _
ByVal fontSize As Double, _
ByVal shrinkToFit As Boolean, _
ByVal horizontalAlign As MsoParagraphAlignment, _
ByVal verticalAnchor As MsoVerticalAnchor)
Dim shp As Shape
Set shp = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, leftPts, topPts, widthPts, heightPts)
shp.Name = shpName
shp.Placement = xlMoveAndSize
With shp
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
With .TextFrame2
.TextRange.Text = textValue
.TextRange.ParagraphFormat.Alignment = horizontalAlign
.VerticalAnchor = verticalAnchor
.MarginLeft = 2
.MarginRight = 1
.MarginTop = 1
.MarginBottom = 1
.WordWrap = msoTrue
If shrinkToFit Then
.AutoSize = msoAutoSizeTextToFitShape
Else
.AutoSize = msoAutoSizeNone
End If
With .TextRange.Font
.Size = fontSize
.Bold = msoFalse
.Fill.ForeColor.RGB = RGB(0, 0, 0)
End With
End With
End With
End Sub
Private Sub SortVariantArray(ByRef arr As Variant)
Dim i As Long
Dim j As Long
Dim tmp As Variant
If IsEmpty(arr) Then Exit Sub
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If CStr(arr(i)) > CStr(arr(j)) Then
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
End If
Next j
Next i
End Sub