diff --git a/src/module/Global_Cache.bas b/src/module/Global_Cache.bas index bf87e6c..38138e7 100644 --- a/src/module/Global_Cache.bas +++ b/src/module/Global_Cache.bas @@ -308,3 +308,99 @@ End Sub Public Sub ClearO2Cache() Set o2Cache = Nothing 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 \ No newline at end of file diff --git a/src/module/Module_Common.bas b/src/module/Module_Common.bas index 2b2b7ae..dc87483 100644 --- a/src/module/Module_Common.bas +++ b/src/module/Module_Common.bas @@ -242,3 +242,13 @@ End Sub Function MakeSelect(ByVal code As String, ByVal value As String) As String MakeSelect = Trim(code) & ":" & Trim(value) 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 diff --git a/src/thisWorkbook/Master_M1_Kukan.bas b/src/thisWorkbook/Master_M1_Kukan.bas index 503eaac..bd14c7a 100644 --- a/src/thisWorkbook/Master_M1_Kukan.bas +++ b/src/thisWorkbook/Master_M1_Kukan.bas @@ -18,38 +18,19 @@ Const END_COL As Long = 14 ' N column Const ERROR_COL As Long = 15 ' O column Const M1_HEADER_ROW As Long = 5 -Private enumCache As Object ' Enum cache - Function HEADERS() As Variant HEADERS = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") 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 Private Sub CreateEnumDropdown(ByVal rowNum As Long) - If enumCache Is Nothing Then Call RefreshEnumCache - ' Build dropdown list from enumCache keys + If tokubetuList Is Nothing Then Call GetTokubetu + ' Build dropdown list from tokubetuList Dim dropdownList As String dropdownList = "" Dim key As Variant - For Each key In enumCache.Keys + For Each key In tokubetuList.Keys If dropdownList = "" Then dropdownList = key Else @@ -212,10 +193,10 @@ Sub validate(ByVal rowNum As Long, ByVal lastDataRow As Long) End If End If - ' Check L column in the cache - If enumCache Is Nothing Then Call RefreshEnumCache + ' Check L column in the tokubetuList + If tokubetuList Is Nothing Then Call GetTokubetu 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.Range("L" & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub diff --git a/src/thisWorkbook/Tukin_C1.bas b/src/thisWorkbook/Tukin_C1.bas index 2a532bb..5725d54 100644 --- a/src/thisWorkbook/Tukin_C1.bas +++ b/src/thisWorkbook/Tukin_C1.bas @@ -80,7 +80,29 @@ End Function ' Event Handlers ' ============================================================ 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 + + Application.EnableEvents = False + On Error GoTo Finally + + ' === 3. rebuild dropdown list === + Call RebuildDropdownsForTarget(Target) ' === Column C changes === If Target.Column = 3 Then @@ -90,10 +112,6 @@ Private Sub Worksheet_Change(ByVal Target As Range) Call ClearRowData(cell.Row) Else 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 Next End If @@ -104,10 +122,10 @@ Private Sub Worksheet_Change(ByVal Target As Range) If idx >= 0 Then Dim cellT As Range 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 - Call CreateZ1StationDropdown(cellT.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx)) - Else - Call ClearKukanValidation(cellT.Row, KUKAN_STATION_COLS(idx)) + Call CreateFromStationDropdown(cellT.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx)) End If Next End If @@ -117,16 +135,10 @@ Private Sub Worksheet_Change(ByVal Target As Range) If idx >= 0 Then Dim cellU As Range For Each cellU In Target + ' Clear arrival value first + Me.Cells(cellU.Row, KUKAN_ARRIVAL_COLS(idx)).ClearContents If Trim(cellU.Value) <> "" Then - Call CreateM1KukanDDropdown(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)) + Call CreateToStationDropdown(cellU.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx)) End If Next End If @@ -137,7 +149,6 @@ Private Sub Worksheet_Change(ByVal Target As Range) Dim cellK As Range For Each cellK In Target 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 Call FillKukanFromM1(cellK.Row, KUKAN_CODE_COLS(idx), Array(KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx))) End If @@ -162,6 +173,111 @@ Private Sub Worksheet_Change(ByVal Target As Range) End If Next 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 ' 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 ' 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 - - ' Build dropdown list: 区分:交通機関名称 + Dim dropdownList As String Dim key As Variant For Each key In z1Cache.Keys @@ -236,24 +351,141 @@ Private Sub CreateZ1TransportDropdown(ByVal rowNum As Long, ByVal col As Long) dropdownList = dropdownList & "," & displayText End If Next key - - If dropdownList <> "" Then - With Me.Cells(rowNum, col).Validation - .Delete - .Add Type:=xlValidateList, Formula1:=dropdownList - .IgnoreBlank = True - .InCellDropdown = True - .InputTitle = "" - .InputMessage = "" - End With - End If -End Sub + + BuildTransportList = dropdownList +End Function + +' Create todoke (G) dropdown +Private Function BuildTodokeList() + If todokeList Is Nothing Then Call GetTodokeList + + Dim dropdownList As String + 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 + 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 -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 - 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 ' 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 ' 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 - Dim transport As String: transport = Trim(Me.Cells(rowNum, transportCol).Value) - Dim stationFrom As String: stationFrom = Trim(Me.Cells(rowNum, stationFromCol).Value) + Dim transport As String: transport = GetCode(Me.Cells(rowNum, transportCol).Value) + Dim stationFrom As String: stationFrom = GetCode(Me.Cells(rowNum, stationFromCol).Value) If transport = "" Or stationFrom = "" Then Exit Sub ' Build dropdown list from M1_KukanD cache diff --git a/通勤手当テンプレート_案.xlsm b/通勤手当テンプレート_案.xlsm index e82221c..8427024 100644 Binary files a/通勤手当テンプレート_案.xlsm and b/通勤手当テンプレート_案.xlsm differ