updsv7/vba
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

update C1

Browse Source
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
Download Patch File Download Diff File Expand all files Collapse all files

96
src/module/Global_Cache.bas
View File

@@ -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

10
src/module/Module_Common.bas
View File

@@ -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

31
src/thisWorkbook/Master_M1_Kukan.bas
View File

@@ -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

302
src/thisWorkbook/Tukin_C1.bas
View File

@@ -80,8 +80,30 @@ 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
Dim cell As Range
@@ -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
@@ -237,23 +352,140 @@ Private Sub CreateZ1TransportDropdown(ByVal rowNum As Long, ByVal col As Long)
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

BIN
通勤手当テンプレート_案.xlsm
View File

Binary file not shown.