update C1

This commit is contained in:
updsv7
2026-04-17 16:22:07 +09:00
parent 8b894ada0a
commit f967c165c0
5 changed files with 381 additions and 62 deletions

View File

@@ -308,3 +308,99 @@ End Sub
Public Sub ClearO2Cache() Public Sub ClearO2Cache()
Set o2Cache = Nothing Set o2Cache = Nothing
End Sub End Sub
' ============================================================
' tokubetuList
' ============================================================
Public tokubetuList As Object
Public Sub GetTokubetu()
On Error GoTo RefreshError
Set tokubetuList = LoadLookup("Enum", keyCol:=1, valueCols:=Array(1), startRow:=3)
On Error GoTo 0
If tokubetuList Is Nothing Or tokubetuList.Count = 0 Then
Err.Raise 1003, "GetTokubetu", "Enum reference data is empty"
End If
Exit Sub
RefreshError:
Err.Raise 1001, "GetTokubetu", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Public Sub ClearTokubetu()
Set tokubetuList = Nothing
End Sub
' ============================================================
' todokeList
' ============================================================
Public todokeList As Object
Public Sub GetTodokeList()
On Error GoTo RefreshError
Set todokeList = LoadLookup("Enum", keyCol:=6, valueCols:=Array(7), startRow:=3)
On Error GoTo 0
If todokeList Is Nothing Or todokeList.Count = 0 Then
Err.Raise 1003, "GetTodokeList", "Enum reference data is empty"
End If
Exit Sub
RefreshError:
Err.Raise 1001, "GetTodokeList", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Public Sub ClearTodokeList()
Set todokeList = Nothing
End Sub
' ============================================================
' oufukuList
' ============================================================
Public oufukuList As Object
Public Sub GetOufukuList()
On Error GoTo RefreshError
Set oufukuList = LoadLookup("Enum", keyCol:=9, valueCols:=Array(10), startRow:=3)
On Error GoTo 0
If oufukuList Is Nothing Or oufukuList.Count = 0 Then
Err.Raise 1003, "GetOufukuList", "Enum reference data is empty"
End If
Exit Sub
RefreshError:
Err.Raise 1001, "GetOufukuList", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Public Sub ClearOufukuList()
Set oufukuList = Nothing
End Sub
' ============================================================
' koutaiList
' ============================================================
Public koutaiList As Object
Public Sub GetKoutaiList()
On Error GoTo RefreshError
Set koutaiList = LoadLookup("Enum", keyCol:=12, valueCols:=Array(13), startRow:=3)
On Error GoTo 0
If koutaiList Is Nothing Or koutaiList.Count = 0 Then
Err.Raise 1003, "GetKoutaiList", "Enum reference data is empty"
End If
Exit Sub
RefreshError:
Err.Raise 1001, "GetKoutaiList", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Public Sub ClearKoutaiList()
Set koutaiList = Nothing
End Sub

View File

@@ -242,3 +242,13 @@ End Sub
Function MakeSelect(ByVal code As String, ByVal value As String) As String Function MakeSelect(ByVal code As String, ByVal value As String) As String
MakeSelect = Trim(code) & ":" & Trim(value) MakeSelect = Trim(code) & ":" & Trim(value)
End Function End Function
' Get left part of MakeSelect format (e.g., "1:JR" -> "1")
Function GetCode(ByVal text As String) As String
Dim pos As Long: pos = InStr(text, ":")
If pos > 0 Then
GetCode = Left(text, pos - 1)
Else
GetCode = text
End If
End Function

View File

@@ -18,38 +18,19 @@ Const END_COL As Long = 14 ' N column
Const ERROR_COL As Long = 15 ' O column Const ERROR_COL As Long = 15 ' O column
Const M1_HEADER_ROW As Long = 5 Const M1_HEADER_ROW As Long = 5
Private enumCache As Object ' Enum cache
Function HEADERS() As Variant Function HEADERS() As Variant
HEADERS = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") HEADERS = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N")
End Function End Function
' ====== Function ======
Public Sub RefreshEnumCache()
On Error GoTo RefreshError
Set tokubetuKbn = LoadLookup("Enum", keyCol:=1, valueCols:=Array(1), startRow:=3)
Set enumCache = tokubetuKbn
On Error GoTo 0
If enumCache Is Nothing Or enumCache.Count = 0 Then
Err.Raise 1003, "RefreshEnumCache", "Enum reference data is empty"
End If
Exit Sub
RefreshError:
Err.Raise 1001, "RefreshEnumCache", "Failed to load Enum lookup cache: " & Err.Description
End Sub
' Create dropdown for L column ' Create dropdown for L column
Private Sub CreateEnumDropdown(ByVal rowNum As Long) Private Sub CreateEnumDropdown(ByVal rowNum As Long)
If enumCache Is Nothing Then Call RefreshEnumCache If tokubetuList Is Nothing Then Call GetTokubetu
' Build dropdown list from enumCache keys ' Build dropdown list from tokubetuList
Dim dropdownList As String Dim dropdownList As String
dropdownList = "" dropdownList = ""
Dim key As Variant Dim key As Variant
For Each key In enumCache.Keys For Each key In tokubetuList.Keys
If dropdownList = "" Then If dropdownList = "" Then
dropdownList = key dropdownList = key
Else Else
@@ -212,10 +193,10 @@ Sub validate(ByVal rowNum As Long, ByVal lastDataRow As Long)
End If End If
End If End If
' Check L column in the cache ' Check L column in the tokubetuList
If enumCache Is Nothing Then Call RefreshEnumCache If tokubetuList Is Nothing Then Call GetTokubetu
Dim lValue As String: lValue = Trim(ws.Range("L" & rowNum).Value) Dim lValue As String: lValue = Trim(ws.Range("L" & rowNum).Value)
If Not enumCache.Exists(lValue) Then If Not tokubetuList.Exists(lValue) Then
ws.Cells(rowNum, ERROR_COL).Value = "L column does not exist." ws.Cells(rowNum, ERROR_COL).Value = "L column does not exist."
ws.Range("L" & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range("L" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub

View File

@@ -80,8 +80,30 @@ End Function
' Event Handlers ' Event Handlers
' ============================================================ ' ============================================================
Private Sub Worksheet_Change(ByVal Target As Range) Private Sub Worksheet_Change(ByVal Target As Range)
Dim watchArea As Range
With Me
Set watchArea = Union( _
.Columns("C"), _
.Columns("E"), _
.Columns("G"), _
.Columns("I"), _
.Columns("S:W"), _
.Columns("Z:AD"), _
.Columns("AG:AK"), _
.Columns("AN:AR") _
)
End With
Dim intersectRng As Range: Set intersectRng = Application.Intersect(Target, watchArea)
If intersectRng Is Nothing Then Exit Sub
If Target.Row < 7 Then Exit Sub If Target.Row < 7 Then Exit Sub
Application.EnableEvents = False
On Error GoTo Finally
' === 3. rebuild dropdown list ===
Call RebuildDropdownsForTarget(Target)
' === Column C changes === ' === Column C changes ===
If Target.Column = 3 Then If Target.Column = 3 Then
Dim cell As Range Dim cell As Range
@@ -90,10 +112,6 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Call ClearRowData(cell.Row) Call ClearRowData(cell.Row)
Else Else
Call FillAddressFromO1(cell.Row) Call FillAddressFromO1(cell.Row)
Dim i As Long
For i = 0 To 3
Call CreateZ1TransportDropdown(cell.Row, KUKAN_TRANSPORT_COLS(i))
Next i
End If End If
Next Next
End If End If
@@ -104,10 +122,10 @@ Private Sub Worksheet_Change(ByVal Target As Range)
If idx >= 0 Then If idx >= 0 Then
Dim cellT As Range Dim cellT As Range
For Each cellT In Target For Each cellT In Target
Me.Cells(cellT.Row, KUKAN_STATION_COLS(idx)).ClearContents
Me.Cells(cellT.Row, KUKAN_ARRIVAL_COLS(idx)).ClearContents
If Trim(cellT.Value) <> "" Then If Trim(cellT.Value) <> "" Then
Call CreateZ1StationDropdown(cellT.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx)) Call CreateFromStationDropdown(cellT.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx))
Else
Call ClearKukanValidation(cellT.Row, KUKAN_STATION_COLS(idx))
End If End If
Next Next
End If End If
@@ -117,16 +135,10 @@ Private Sub Worksheet_Change(ByVal Target As Range)
If idx >= 0 Then If idx >= 0 Then
Dim cellU As Range Dim cellU As Range
For Each cellU In Target For Each cellU In Target
' Clear arrival value first
Me.Cells(cellU.Row, KUKAN_ARRIVAL_COLS(idx)).ClearContents
If Trim(cellU.Value) <> "" Then If Trim(cellU.Value) <> "" Then
Call CreateM1KukanDDropdown(cellU.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx)) Call CreateToStationDropdown(cellU.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx))
On Error Resume Next
Dim formula As String: formula = Me.Cells(cellU.Row, KUKAN_ARRIVAL_COLS(idx)).Validation.Formula1
On Error GoTo 0
If formula = "" Then
Call ClearKukanValidation(cellU.Row, KUKAN_ARRIVAL_COLS(idx))
End If
Else
Call ClearKukanValidation(cellU.Row, KUKAN_ARRIVAL_COLS(idx))
End If End If
Next Next
End If End If
@@ -137,7 +149,6 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Dim cellK As Range Dim cellK As Range
For Each cellK In Target For Each cellK In Target
If Trim(cellK.Value) <> "" Then If Trim(cellK.Value) <> "" Then
Call CreateZ1TransportDropdown(cellK.Row, KUKAN_TRANSPORT_COLS(idx))
If Me.Cells(cellK.Row, KUKAN_TRANSPORT_COLS(idx)).Validation.Formula1 <> "" Then If Me.Cells(cellK.Row, KUKAN_TRANSPORT_COLS(idx)).Validation.Formula1 <> "" Then
Call FillKukanFromM1(cellK.Row, KUKAN_CODE_COLS(idx), Array(KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx))) Call FillKukanFromM1(cellK.Row, KUKAN_CODE_COLS(idx), Array(KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx)))
End If End If
@@ -162,6 +173,111 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End If End If
Next Next
End If End If
Finally:
Application.EnableEvents = True '
End Sub
Private Sub RebuildDropdownsForTarget(ByVal Target As Range)
If Target Is Nothing Then Exit Sub
Dim cell As Range
Dim processedRows As Object
Set processedRows = CreateObject("Scripting.Dictionary")
For Each cell In Target
Dim r As Long
r = cell.Row
If Not processedRows.Exists(r) Then
processedRows(r) = True
Dim colLetter As String
colLetter = Split(Me.Cells(1, cell.Column).Address(True, False), "$")(0) ' obtain column
' --- T: Transport ---
If colLetter <> "T" Then
With Me.Cells(r, "T").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=BuildTransportList()
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
' --- G: todoke ---
If colLetter <> "G" Then
With Me.Cells(r, "G").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=BuildTodokeList()
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
' --- M: oufuku ---
If colLetter <> "M" Then
With Me.Cells(r, "M").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=BuildOufukuList()
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
' --- N: koutai ---
If colLetter <> "N" Then
With Me.Cells(r, "N").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=BuildKoutaiList()
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
' --- AU: kettei ---
If colLetter <> "AU" Then
With Me.Cells(r, "AU").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=BuildKetteiList()
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
' --- AW: higaitou ---
If colLetter <> "AW" Then
With Me.Cells(r, "AW").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=BuildHigaitouList()
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
' --- AX: monthAmountKbn ---
If colLetter <> "AX" Then
With Me.Cells(r, "AX").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=BuildMonthAmountKbnList()
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
' --- BC: kanshoku ---
If colLetter <> "BC" Then
With Me.Cells(r, "BC").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=BuildKanshokuList()
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
End If
NextCell:
Next cell
End Sub End Sub
' Fill kukan info from M1 cache (key: kukan code, value: 7 elements) ' Fill kukan info from M1 cache (key: kukan code, value: 7 elements)
@@ -221,10 +337,9 @@ Private Sub FillAddressFromO1(ByVal rowNum As Long)
End Sub End Sub
' Create transport (T) dropdown from Z1 cache ' Create transport (T) dropdown from Z1 cache
Private Sub CreateZ1TransportDropdown(ByVal rowNum As Long, ByVal col As Long) Private Function BuildTransportList()
If z1Cache Is Nothing Then Call RefreshZ1Cache If z1Cache Is Nothing Then Call RefreshZ1Cache
' Build dropdown list: 区分:交通機関名称
Dim dropdownList As String Dim dropdownList As String
Dim key As Variant Dim key As Variant
For Each key In z1Cache.Keys For Each key In z1Cache.Keys
@@ -237,23 +352,140 @@ Private Sub CreateZ1TransportDropdown(ByVal rowNum As Long, ByVal col As Long)
End If End If
Next key Next key
If dropdownList <> "" Then BuildTransportList = dropdownList
With Me.Cells(rowNum, col).Validation End Function
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList ' Create todoke (G) dropdown
.IgnoreBlank = True Private Function BuildTodokeList()
.InCellDropdown = True If todokeList Is Nothing Then Call GetTodokeList
.InputTitle = ""
.InputMessage = "" Dim dropdownList As String
End With Dim key As Variant
For Each key In todokeList.Keys
Dim displayText As String
displayText = MakeSelect(key, todokeList(key)(0))
If dropdownList = "" Then
dropdownList = displayText
Else
dropdownList = dropdownList & "," & displayText
End If End If
End Sub Next key
BuildTodokeList = dropdownList
End Function
' Create oufuku (M) dropdown
Private Function BuildOufukuList()
If oufukuList Is Nothing Then Call GetOufukuList
Dim dropdownList As String
Dim key As Variant
For Each key In oufukuList.Keys
Dim displayText As String
displayText = MakeSelect(key, oufukuList(key)(0))
If dropdownList = "" Then
dropdownList = displayText
Else
dropdownList = dropdownList & "," & displayText
End If
Next key
BuildOufukuList = dropdownList
End Function
' Create Koutai (N) dropdown
Private Function BuildKoutaiList()
If koutaiList Is Nothing Then Call GetKoutaiList
Dim dropdownList As String
Dim key As Variant
For Each key In koutaiList.Keys
Dim displayText As String
displayText = MakeSelect(key, koutaiList(key)(0))
If dropdownList = "" Then
dropdownList = displayText
Else
dropdownList = dropdownList & "," & displayText
End If
Next key
BuildKoutaiList = dropdownList
End Function
' Create Kettei (AU) dropdown
Private Function BuildKetteiList()
If z1Cache Is Nothing Then Call RefreshZ1Cache
Dim dropdownList As String
Dim key As Variant
For Each key In z1Cache.Keys
Dim displayText As String
displayText = MakeSelect(key, z1Cache(key)(0))
If dropdownList = "" Then
dropdownList = displayText
Else
dropdownList = dropdownList & "," & displayText
End If
Next key
BuildKetteiList = dropdownList
End Function
' Create Higaitou (AW) dropdown
Private Function BuildHigaitouList()
If z1Cache Is Nothing Then Call RefreshZ1Cache
Dim dropdownList As String
Dim key As Variant
For Each key In z1Cache.Keys
Dim displayText As String
displayText = MakeSelect(key, z1Cache(key)(0))
If dropdownList = "" Then
dropdownList = displayText
Else
dropdownList = dropdownList & "," & displayText
End If
Next key
BuildHigaitouList = dropdownList
End Function
' Create MonthAmountKbn (AX) dropdown
Private Function BuildMonthAmountKbnList()
If z1Cache Is Nothing Then Call RefreshZ1Cache
Dim dropdownList As String
Dim key As Variant
For Each key In z1Cache.Keys
Dim displayText As String
displayText = MakeSelect(key, z1Cache(key)(0))
If dropdownList = "" Then
dropdownList = displayText
Else
dropdownList = dropdownList & "," & displayText
End If
Next key
BuildMonthAmountKbnList = dropdownList
End Function
' Create Kanshoku (BC) dropdown
Private Function BuildKanshokuList()
If z1Cache Is Nothing Then Call RefreshZ1Cache
Dim dropdownList As String
Dim key As Variant
For Each key In z1Cache.Keys
Dim displayText As String
displayText = MakeSelect(key, z1Cache(key)(0))
If dropdownList = "" Then
dropdownList = displayText
Else
dropdownList = dropdownList & "," & displayText
End If
Next key
BuildKanshokuList = dropdownList
End Function
' Create station (利用区間発) dropdown from M1_KukanD cache ' Create station (利用区間発) dropdown from M1_KukanD cache
Private Sub CreateZ1StationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationCol As Long) Private Sub CreateFromStationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationCol As Long)
If m1KukanDCache Is Nothing Then Call RefreshM1KukanDCache If m1KukanDCache Is Nothing Then Call RefreshM1KukanDCache
Dim transport As String: transport = Trim(Me.Cells(rowNum, transportCol).Value) Dim transport As String: transport = GetCode(Me.Cells(rowNum, transportCol).Value)
If transport = "" Then Exit Sub If transport = "" Then Exit Sub
' Build dropdown list from M1_KukanD cache: get all F values for the transport (D) ' Build dropdown list from M1_KukanD cache: get all F values for the transport (D)
@@ -282,11 +514,11 @@ End Sub
' Create destination (利用区間着) dropdown from M1_KukanD cache ' Create destination (利用区間着) dropdown from M1_KukanD cache
' Structure: { D: { F: [G] } } ' Structure: { D: { F: [G] } }
Private Sub CreateM1KukanDDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long) Private Sub CreateToStationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long)
If m1KukanDCache Is Nothing Then Call RefreshM1KukanDCache If m1KukanDCache Is Nothing Then Call RefreshM1KukanDCache
Dim transport As String: transport = Trim(Me.Cells(rowNum, transportCol).Value) Dim transport As String: transport = GetCode(Me.Cells(rowNum, transportCol).Value)
Dim stationFrom As String: stationFrom = Trim(Me.Cells(rowNum, stationFromCol).Value) Dim stationFrom As String: stationFrom = GetCode(Me.Cells(rowNum, stationFromCol).Value)
If transport = "" Or stationFrom = "" Then Exit Sub If transport = "" Or stationFrom = "" Then Exit Sub
' Build dropdown list from M1_KukanD cache ' Build dropdown list from M1_KukanD cache