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

add kenshuList

Browse Source
This commit is contained in:
updsv7
2026-04-20 12:34:54 +09:00
parent 7f271043b7
commit 33f16bb248
4 changed files with 180 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/init_module/Import_modules.bas
View File

@@ -5,7 +5,7 @@ Sub ImportModulesAndSheets_Safe()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Const PROJECT_PATH As String = "E:\AI\project\updsv7\vba\"
Const PROJECT_PATH As String = "D:\Project\upds7\vba\"
Const MODULE_PATH As String = PROJECT_PATH & "src\module"
Const SHEET_PATH As String = PROJECT_PATH & "src\sheet"

26
src/module/Common_Global_Cache.bas
View File

@@ -29,6 +29,7 @@ Private tokubetuList As Object
Private oufukuList As Object
Private koutaiList As Object
Private higaitouList As Object
Private kenshuList As Object
Private sheetConfDict As Object
@@ -277,7 +278,7 @@ Private Sub RefreshO1Cache()
End If
Set arr = innerDict(eVal)
If fVal <> "" And Not arr.Exists(fVal) Then
If Not arr.Exists(fVal) Then
arr.Add fVal, True
End If
@@ -377,6 +378,24 @@ RefreshError:
Err.Raise 1001, "GetHigaitouList", "Failed to load Enum lookup cache: " & Err.Description
End Sub
' ============================================================
' higaitouList
' ============================================================
Private Sub RefreshKenshuList()
On Error GoTo RefreshError
Set kenshuList = LoadLookup("Enum", keyCol:=3, valueCols:=Array(4), startRow:=3)
On Error GoTo 0
If kenshuList Is Nothing Or kenshuList.Count = 0 Then
Err.Raise 1003, "RefreshKenshuList", "Enum reference data is empty"
End If
Exit Sub
RefreshError:
Err.Raise 1001, "RefreshKenshuList", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Private Sub RefreshSheetDict()
Set sheetConfDict = CreateObject("Scripting.Dictionary")
Dim sheetConf As Object
@@ -613,3 +632,8 @@ Public Function GetTokubetu() As Object
If tokubetuList Is Nothing Then Call RefreshTokubetu
Set GetTokubetu = tokubetuList
End Function
Public Function GetKenshuList() As Object
If kenshuList Is Nothing Then Call RefreshKenshuList
Set GetKenshuList = kenshuList
End Function

169
src/sheet/C1.cls
View File

@@ -191,6 +191,7 @@ Private Sub Worksheet_Change(ByVal Target As Range)
foundCode = FindKukanCodeByStation(cellV.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx))
If foundCode <> "" Then
Me.Cells(cellV.Row, KUKAN_CODE_COLS(idx)).Value = foundCode
Call CreateKenshuDropdown(cellV.Row, idx, foundCode)
End If
End If
Next
@@ -214,9 +215,7 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(idx)
Me.Cells(cellTi.Row, code2Col).ClearContents
Me.Cells(cellTi.Row, code2Col).Validation.Delete
If Not IsError(Application.Match(cellTi.Value, Array("1", "2", "3"), 0)) Then
Call CreateM2CodeDropdown(cellTi.Row, KUKAN_CODE_COLS(idx), KUKAN_TICKET_COLS(idx), code2Col)
End If
Next
End If
@@ -292,18 +291,20 @@ Private Sub FillKukanFromM1(ByVal rowNum As Long, ByVal idx As Long)
Me.Cells(rowNum, transportCol).Value = MakeSelect(vals(1), vals(2))
Me.Cells(rowNum, stationCol).Value = Trim(vals(3))
Me.Cells(rowNum, arrivalCol).Value = Trim(vals(4))
Call CreateKenshuDropdown(rowNum, idx, code)
Else
Me.Cells(rowNum, transportCol).ClearContents
Me.Cells(rowNum, stationCol).ClearContents
Me.Cells(rowNum, arrivalCol).ClearContents
Me.Cells(rowNum, ticketCol).ClearContents
Me.Cells(rowNum, code2Col).ClearContents
Me.Cells(rowNum, startDayCol).ClearContents
Call ClearKukanValidation(rowNum, stationCol)
Call ClearKukanValidation(rowNum, arrivalCol)
Call ClearKukanValidation(rowNum, code2Col)
End If
Me.Cells(rowNum, ticketCol).ClearContents
Me.Cells(rowNum, code2Col).ClearContents
End Sub
' triggered by c clomun cshainno input
@@ -427,6 +428,39 @@ Private Sub CreateFromStationDropdown(ByVal rowNum As Long, ByVal transportCol A
End If
End Sub
' Create Kenshu dropdown from
' Structure: { D: { F: [G] } }
Private Sub CreateKenshuDropdown(ByVal rowNum As Long, ByVal idx As Long, ByVal kukanCode As String)
Dim kenshuList As Object: Set kenshuList = GetKenshuList()
Dim m2Cache As Object: Set m2Cache = GetM2Cache()
Dim ticketCol As Long: ticketCol = KUKAN_TICKET_COLS(idx)
Me.Cells(rowNum, ticketCol).ClearContents
Call ClearKukanValidation(rowNum, ticketCol)
Dim kanshuDict As Object
if m2Cache.Exists(kukanCode) Then
Set kanshuDict = m2Cache(kukanCode)
End If
Dim dropdownList As String: dropdownList = MakeSelect("0", kenshuList("0")(0))
If Not kanshuDict Is Nothing Then
Dim key As Variant
For Each key In kenshuList.Keys
If kanshuDict.Exists(key) Then
dropdownList = dropdownList & "," & MakeSelect(key, kenshuList(key)(0))
End If
Next key
End If
With Me.Cells(rowNum, ticketCol).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
End With
End Sub
' Create destination dropdown from M1_KukanD cache
' Structure: { D: { F: [G] } }
Private Sub CreateToStationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long)
@@ -499,13 +533,14 @@ Private Sub CreateM2CodeDropdown(ByVal rowNum As Long, ByVal kukanCodeCol As Lon
Dim m2Cache As Object: Set m2Cache = GetM2Cache()
Dim kukanCode As String: kukanCode = Trim(Me.Cells(rowNum, kukanCodeCol).Value)
Dim kanshu As String: kanshu = Trim(Me.Cells(rowNum, kanshuCol).Value)
If kukanCode = "" Or kanshu = "" Then Exit Sub
Dim kanshuStr As String: kanshuStr = Trim(Me.Cells(rowNum, kanshuCol).Value)
If kukanCode = "" Or kanshuStr = "" Then Exit Sub
' Build dropdown list: get all code for kukanCode + kanshu
' Build dropdown list: get all code for kukanCode + kanshuStr
Dim dropdownList As String
If m2Cache.Exists(kukanCode) Then
Dim innerDict As Object: Set innerDict = m2Cache(kukanCode)
Dim kanshu As String: kanshu = GetCode(kanshuStr)
If innerDict.Exists(kanshu) Then
Dim innermostDict As Object: Set innermostDict = innerDict(kanshu)
Dim code As Variant
@@ -599,16 +634,13 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
' validate CodeSelect
' G column [todoke Cde]
Dim ColG As String: ColG = "G"
Dim todoke As String: todoke = Trim(Me.Cells(rowNum, ColG).Value)
If todoke <> "" Then
Dim z4Cache As Object: Set z4Cache = GetZ4Cache()
Dim todokeCde As String: todokeCde = GetCode(todoke)
Dim todokeCde As String: todokeCde = GetCode(Trim(Me.Cells(rowNum, ColG).Value))
If Not z4Cache.Exists(todokeCde) Then
Me.Cells(rowNum, errorCol).Value = ColG & " column is invalid"
Me.Range(ColG & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
End If
' I column [address1 J column address2]
Dim o1Cache As Object: Set o1Cache = GetO1Cache()
@@ -645,25 +677,116 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
End If
' K column
If Trim(Me.Cells(rowNum, "K").Value) <> "" Then
Me.Cells(rowNum, errorCol).Value = "K" & " column can not be input"
Me.Range("K" & rowNum).Interior.Color = RGB(255, 0, 0)
Dim ColK As String: ColK = "K"
If Trim(Me.Cells(rowNum, ColK).Value) <> "" Then
Me.Cells(rowNum, errorCol).Value = ColK & " column can not be input"
Me.Range(ColK & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' validate CodeSelect
' M column [todoke Cde]
Dim ColG As String: ColG = "G"
Dim todoke As String: todoke = Trim(Me.Cells(rowNum, ColG).Value)
If todoke <> "" Then
Dim z4Cache As Object: Set z4Cache = GetZ4Cache()
Dim todokeCde As String: todokeCde = GetCode(todoke)
If Not z4Cache.Exists(todokeCde) Then
Me.Cells(rowNum, errorCol).Value = ColG & " column is invalid"
Me.Range(ColG & rowNum).Interior.Color = RGB(255, 0, 0)
' M column [oufuku]
Dim ColM As String: ColM = "M"
Dim oufukuList As Object: Set oufukuList = GetOufukuList()
Dim oufukuCde As String: oufukuCde = GetCode(Trim(Me.Cells(rowNum, ColM).Value))
If Not oufukuList.Exists(oufukuCde) Then
Me.Cells(rowNum, errorCol).Value = ColM & " column is invalid"
Me.Range(ColM & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' validate CodeSelect
' N column [koutai]
Dim ColN As String: ColN = "N"
Dim koutaiList As Object: Set koutaiList = GetKoutaiList()
Dim koutaiCde As String: koutaiCde = GetCode(Trim(Me.Cells(rowNum, ColN).Value))
If Not koutaiList.Exists(koutaiCde) Then
Me.Cells(rowNum, errorCol).Value = ColN & " column is invalid"
Me.Range(ColN & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' validate KUKAN_CODE_COLS (S, Z, AG, AN) and related columns
Dim m1Cache As Object: Set m1Cache = GetM1Cache()
Dim m2Cache As Object: Set m2Cache = GetM2Cache()
Dim kukanCols As Variant
kukanCols = Array(KUKAN_TRANSPORT_COLS, KUKAN_STATION_COLS, KUKAN_ARRIVAL_COLS, KUKAN_TICKET_COLS, KUKAN_CODE2_COLS, KUKAN_START_DAY_COLS)
Dim kukanIdx As Long
For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS)
Dim kukanCol As Long: kukanCol = KUKAN_CODE_COLS(kukanIdx)
Dim kukanCode As String: kukanCode = Trim(Me.Cells(rowNum, kukanCol).Value)
Dim kukanLetter As String: kukanLetter = Split(Me.Cells(1, kukanCol).Address, "$")(1)
If kukanCode <> "" Then
' KUKAN_CODE has value, check if exists in m1Cache
If Not m1Cache.Exists(kukanCode) Then
Me.Cells(rowNum, errorCol).Value = kukanLetter & " column does not exist"
Me.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' Validate KUKAN_TICKET_COLS and KUKAN_CODE2_COLS
Dim ticketCol As Long: ticketCol = KUKAN_TICKET_COLS(kukanIdx)
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(kukanIdx)
Dim ticketVal As String: ticketVal = GetCode(Trim(Me.Cells(rowNum, ticketCol).Value))
Dim code2Val As String: code2Val = GetCode(Trim(Me.Cells(rowNum, code2Col).Value))
Dim ticketLetter As String: ticketLetter = Split(Me.Cells(1, ticketCol).Address, "$")(1)
Dim code2Letter As String: code2Letter = Split(Me.Cells(1, code2Col).Address, "$")(1)
If ticketVal = "" Then
Me.Cells(rowNum, errorCol).Value = ticketLetter & " column must be input"
Me.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If ticketVal = "0" Then
If code2Val <> "" Then
Me.Cells(rowNum, errorCol).Value = code2Letter & " column is invalid"
Me.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Else
' Check if ticket exists in m2Cache for this kukanCode
Dim kanshuDict As Object
If m2Cache.Exists(kukanCode) Then
Set kanshuDict = m2Cache(kukanCode)
If Not kanshuDict.Exists(ticketVal) Then
Me.Cells(rowNum, errorCol).Value = ticketLetter & " column is invalid"
Me.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' If code2 also has value, verify it exists in m2Cache
If code2Val = "" Then
Me.Cells(rowNum, errorCol).Value = code2Letter & " column should be input"
Me.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
Else
Dim codeDict As Object: Set codeDict = kanshuDict(ticketVal)
If Not codeDict.Exists(code2Val) Then
Me.Cells(rowNum, errorCol).Value = code2Letter & " column is invalid"
Me.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
End If
End If
End If
Else
' KUKAN_CODE is empty, check that related columns are also empty
Dim colGroup As Variant
For Each colGroup In kukanCols
Dim checkCol As Long: checkCol = colGroup(kukanIdx)
Dim checkVal As String: checkVal = Trim(Me.Cells(rowNum, checkCol).Value)
If checkVal <> "" Then
Dim checkLetter As String: checkLetter = Split(Me.Cells(1, checkCol).Address, "$")(1)
Me.Cells(rowNum, errorCol).Value = checkLetter & " column requires " & kukanLetter & " column"
Me.Range(checkLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next colGroup
End If
Next kukanIdx
Me.Cells(rowNum, errorCol).ClearContents
End Sub

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

Binary file not shown.