diff --git a/src/init_module/Import_modules.bas b/src/init_module/Import_modules.bas index 71db349..c90ced6 100644 --- a/src/init_module/Import_modules.bas +++ b/src/init_module/Import_modules.bas @@ -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" diff --git a/src/module/Common_Global_Cache.bas b/src/module/Common_Global_Cache.bas index 6dd7acd..3a53459 100644 --- a/src/module/Common_Global_Cache.bas +++ b/src/module/Common_Global_Cache.bas @@ -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 @@ -612,4 +631,9 @@ End Function 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 \ No newline at end of file diff --git a/src/sheet/C1.cls b/src/sheet/C1.cls index d9c841b..e35468d 100644 --- a/src/sheet/C1.cls +++ b/src/sheet/C1.cls @@ -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 + Call CreateM2CodeDropdown(cellTi.Row, KUKAN_CODE_COLS(idx), KUKAN_TICKET_COLS(idx), code2Col) 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,15 +634,12 @@ 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) - 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 + Dim z4Cache As Object: Set z4Cache = GetZ4Cache() + 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 ' I column [address1 J column address2] @@ -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) - Exit Sub - End If + ' 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 diff --git a/通勤手当テンプレート_案.xlsm b/通勤手当テンプレート_案.xlsm index 62dd213..1999e57 100644 Binary files a/通勤手当テンプレート_案.xlsm and b/通勤手当テンプレート_案.xlsm differ